Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOSPML4

PSOSPML4.m

Go to the documentation of this file.
PSOSPML4 ;BIRM/MFR - Single Prescritpion ASAP Data Listman Driver ;09/01/12
 ;;7.0;OUTPATIENT PHARMACY;**408,451**;DEC 1997;Build 114
 ;
 N DIR,DIRUT,X,PSOQUIT,RXIEN,SCREEN,STATEIEN,PSOTTCNT,PSOTPCNT,DFN,VALM,VALMCNT,VALMHDR,VALMBCK,VALMSG,PSOLSTLN
 ;
RX ; - Prescription prompt
 K DIR S DIR(0)="FAO^1:30",DIR("A")=" PRESCRIPTION: ",(DIR("?"),DIR("??"))="^D HLP^PSORXVW1"
 W ! D ^DIR I X=""!$D(DIRUT) G EXIT
 S X=$$UP^XLFSTR(X),PSOQUIT=0
 I $E(X,1,2)'="E." S RXIEN=+$$RXLKP(X) I RXIEN<0 G RX
 I $E(X,1,2)="E." D  I PSOQUIT G RX
 . I $L(X)'=9 W !?5,"The ECME# must be 7 digits long!",$C(7) S PSOQUIT=1 Q
 . S RXIEN=+$$RXNUM^PSOBPSU2($E(X,3,9)) I RXIEN<0 W " ??" S PSOQUIT=1
 ;
 S FILLNUM=$$RXFILL^PSOSPMU2(RXIEN) I FILLNUM="^" G EXIT
 ;
 S SCREEN=$$SCREEN^PSOSPMUT(RXIEN,FILLNUM)
 I +SCREEN D  G RX:$P(SCREEN,"^",3)="E"
 . W !!?1,$S($P(SCREEN,"^",3)="E":"ERROR",1:"WARNING"),": ",$P(SCREEN,"^",2),$C(7) D PAUSE^PSOSPMU1
 ;
 ; The legislation allowing VA to report was published on 02/11/2013
 I $$RXRLDT^PSOBPSUT(RXIEN,FILLNUM),$$RXRLDT^PSOBPSUT(RXIEN,FILLNUM)<3130211 D  G RX
 . W !!?1,"Only prescription fills dispensed on or after Feb 11, 2013 can be exported.",$C(7)
 ;
 D EN(RXIEN,FILLNUM,"N")
 ;
 G RX
 ;
EN(RXIEN,FILLNUM,RECTYPE) ; Entry point
 N ASAP,SITEIEN,PATIEN,FILLIEN,DRUGIEN,PREIEN,RPHIEN,RSTREC,RTSDATA,PSONAME,TRXTYPE,RTSREC
 ;
 S:$G(FILLNUM)="" FILLNUM=0
 S STATEIEN=$$RXSTATE^PSOBPSUT(RXIEN,0)
 S PSOASVER=$$GET1^DIQ(58.41,STATEIEN,1,"I") S:PSOASVER="" PSOASVER="4.2"
 S SITEIEN=$$RXSITE^PSOBPSUT(RXIEN,0)
 S (PATIEN,DFN)=$$GET1^DIQ(52,RXIEN,2,"I")
 D DEM^VADPT,ADD^VADPT,SETNAME^PSOSPMUT(DFN)
 S DRUGIEN=$$GET1^DIQ(52,RXIEN,6,"I")
 S FILLIEN=$S(FILLNUM["P":+$P(FILLNUM,"P",2),1:+FILLNUM)
 S TRXTYPE="S"
 K RTSDATA S RTSREC=0 I RECTYPE="V" S RTSREC=1 D LOADRTS^PSOSPMU1(RXIEN,FILLNUM,.RTSDATA)
 S PREIEN=$$PREIEN^PSOSPMUT(RECTYPE,RXIEN,FILLNUM)
 S RPHIEN=$$RPHIEN^PSOSPMUT(RECTYPE,RXIEN,FILLNUM)
 D EN^VALM("PSO SPMP VIEW/EXPORT RX")
 D FULL^VALM1
 Q
 ;
HDR ; - Builds the Header section
 N LINE1,LINE2,X
 K VALMHDR S VALMHDR(1)="Rx: "_$$GET1^DIQ(52,RXIEN,.01)_" - "_$$GET1^DIQ(52,RXIEN,6)
 S VALMHDR(1)=VALMHDR(1)_"   (Fill: "_$S(FILLNUM["P":"Partial "_$E(FILLNUM,2,9),'FILLNUM:"Original",1:"Refill "_FILLNUM)_")"
 S VALMHDR(2)="Patient: "_$$GET1^DIQ(52,RXIEN,2)_"            ASAP Version: "_PSOASVER
 Q
 ;
INIT ; Builds the Body section 
 N ASAP,LINE
 ;
 D CLEAN^VALM10 K ^TMP("PSOSPML4",$J) S VALMCNT=0,LINE=0
 I PSOASVER="1995" D
 . D SETSEG95("PSOSPML4",$$ASAP95^PSOASAP0(RXIEN,+FILLNUM)) S VALMCNT=LINE
 I PSOASVER'="1995" D
 . S (PSOTTCNT,PSOTPCNT)=0
 . D LOADASAP^PSOSPMU0(PSOASVER,"B",.ASAP)
 . D SETSEG("ASAP") S VALMCNT=LINE
 . S VALMSG="Enter ?? for more actions|* Custom Segment/Element"
 Q
 ;
SETSEG(ARRNAM) ; Sets list body with ASAP (non-1995) info (Uses Recurisivity - Call itself)
 ;Input: ARRNAM - Name of the Array containing the ASAP Definition ('ASAP')
 ;
 N ARRAY,SEGID,DETLN,VALUE,RXLN,COLUMN,I,TMPARR,SEGTXT,LSTELM
 S ARRAY=$Q(@ARRNAM) I '+$P(ARRAY,"(",2) Q
 S SEGID=@ARRAY,COLUMN=(($L(ARRAY,",")-1)*4)
 ; Segment Not Used by ASAP Version
 I $P(ASAP(SEGID),"^",4)="N" D SETSEG(ARRAY) Q
 D SETLN^PSOSPMU1("PSOSPML4",$P(ASAP(SEGID),"^")_$S($$CUSSEG^PSOSPMU3(PSOASVER,SEGID):"*",1:"")_" "_$P(ASAP(SEGID),"^",2),0,1)
 D SEGCOUNT^PSOSPMUT($P(ASAP(SEGID),"^",6))
 K TMPARR S SEGTXT=SEGID
 S LSTELM=+$O(ASAP(SEGID,""),-1)
 N $ETRAP,$ESTACK S $ETRAP="D ERROR^PSOSPML4"
 F I=1:1:LSTELM D
 . S VALUE="" I $P(ASAP(SEGID,I),"^",6)'="N" X "S VALUE="_ASAP(SEGID,I,"VAL",1)
 . S VALUE=$E(VALUE,1,$P(ASAP(SEGID,I),"^",4))
 . S SEGTXT=SEGTXT_$P(ASAP,"^",2)_VALUE
 . S RXLN=$S($G(VALUE)'="":VALUE,1:$P(ASAP,"^",2))
 . S $E(RXLN,40)=$P(ASAP(SEGID,I),"^")_$S($G(ASAP(SEGID,I,"CUS")):"* ",1:" ")_$P(ASAP(SEGID,I),"^",2)_$S($P(ASAP(SEGID,I),"^",6)="N":" (Not Used)",1:"")
 . S TMPARR(I)=RXLN I $G(ASAP(SEGID,I,"CUS")) S TMPARR(I,"HIGH")=1
 S SEGTXT=SEGTXT_$S(PSOASVER="3.0":$$TH13^PSOASAP0(),1:$$TH09^PSOASAP0())
 ;
 F I=1:1 Q:SEGTXT=""  D SETLN^PSOSPMU1("PSOSPML4",$E(SEGTXT,1,80)) S SEGTXT=$E(SEGTXT,81,999)
 F I=1:1 Q:'$D(TMPARR(I))  D SETLN^PSOSPMU1("PSOSPML4",TMPARR(I),,,+$G(TMPARR(I,"HIGH")))
 ;
 D SETSEG(ARRAY)
 Q
 ;
ERROR ; Error Trap Handling to catch errors on user-entered M expression
 D SETLN^PSOSPMU1("PSOSPML4",$E($$EC^%ZOSV,1,80))
 G UNWIND^%ZTER
 ;
SETSEG95(LSTSUB,RECORD) ; Sets list body with ASAP 1995 info
 N DSPL,PSOCOL
 S PSOCOL=$S(LSTSUB="PSOSPML3":1,1:31)
 S:LSTSUB="PSOSPML4" DSPL="VALUE" S $E(DSPL,PSOCOL)="POSITION  DESCRIPTION" D SETLN^PSOSPMU1(LSTSUB,DSPL,0,1,0)
 S DSPL=$E(RECORD,1,3),$E(DSPL,PSOCOL)="(001-003) Transmission Type Identifier" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,4,9),$E(DSPL,PSOCOL)="(004-009) Bank Identification Number ('VA'_Site#)" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,10,11),$E(DSPL,PSOCOL)="(010-011) ASAP Version ('A2': 1995)" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,12,13),$E(DSPL,PSOCOL)="(012-013) Transaction Code ('01': Controlled Sub)" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,14,25),$E(DSPL,PSOCOL)="(014-025) Pharmacy DEA Number" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,26,45),$E(DSPL,PSOCOL)="(026-045) Patient ID (SSN)" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,46,48),$E(DSPL,PSOCOL)="(046-048) Patient's Zip Code (first 3 digits)" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,49,56),$E(DSPL,PSOCOL)="(049-056) Patient's DOB  (Format: YYYYMMDD)" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,57,57),$E(DSPL,PSOCOL)="(057-057) Patient's Gender ('1':Male/'2':Female)" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,58,65),$E(DSPL,PSOCOL)="(058-065) Date Filled (Release Date) (YYYYMMDD)" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,66,72),$E(DSPL,PSOCOL)="(066-072) Prescription Number (last 7 of Rx IEN)" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,73,74),$E(DSPL,PSOCOL)="(073-074) Rx Fill Number" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,75,79),$E(DSPL,PSOCOL)="(075-079) Rx Quantity" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,80,82),$E(DSPL,PSOCOL)="(080-082) Rx Days Supply" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,83,83),$E(DSPL,PSOCOL)="(083-083) Compound Flag (Always '1':Not Compound)" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,84,94),$E(DSPL,PSOCOL)="(084-094) NDC (Format: 99999999999)" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,95,104),$E(DSPL,PSOCOL)="(095-104) Prescriber's DEA #" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,105,108),$E(DSPL,PSOCOL)="(105-108) Prescriber's DEA Suffix (Not Used)" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,109,116),$E(DSPL,PSOCOL)="(109-116) Date Written (Format: YYYYMMDD)" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,117,118),$E(DSPL,PSOCOL)="(117-118) Refills Authorized" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,119,119),$E(DSPL,PSOCOL)="(119-119) Origin Code(0:Unknown,1:Written,2:Phone)" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,120,121),$E(DSPL,PSOCOL)="(120-121) Customer Location ('03':Outpatient)" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,122,128),$E(DSPL,PSOCOL)="(122-128) Diagnosis Code (Not Used)" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,129,138),$E(DSPL,PSOCOL)="(129-138) Alternate Prescriber's # (VA #)" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,139,153),$E(DSPL,PSOCOL)="(139-153) Patient's Last Name" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,154,168),$E(DSPL,PSOCOL)="(154-168) Patient's First Name" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,169,198),$E(DSPL,PSOCOL)="(169-198) Patient's Address" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,199,200),$E(DSPL,PSOCOL)="(199-200) Patient's State" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 S DSPL=$E(RECORD,201,209),$E(DSPL,PSOCOL)="(201-209) Patient's Zip Code" D SETLN^PSOSPMU1(LSTSUB,DSPL)
 Q
 ;
ASAPDEF ; - Invokes Listman for ASAP Definitions
 N STATE
 S STATE=$$RXSTATE^PSOBPSUT(RXIEN,0)
 S PSOASVER=$$GET1^DIQ(58.41,STATE,1,"I") S:PSOASVER="" PSOASVER="4.2"
 D FULL^VALM1 W !
 D EN^PSOSPML3(PSOASVER,1),INIT S VALMBCK="R"
 Q
 ;
EXPORT ; - Export Rx
 N STATEIEN,PSOASVER,PSOTXRTS,BATIEN,DIR,X,Y,DIRUT,DUOUT,RECTYPE,SCREEN,DFN
 S VALMBCK="R"
 S STATEIEN=$$RXSTATE^PSOBPSUT(RXIEN,0)
 S PSOASVER=$$GET1^DIQ(58.41,STATEIEN,1,"I")
 S PSOTXRTS=+$$GET1^DIQ(58.41,STATEIEN,12,"I")
 ;
 I 'STATEIEN D  Q
 . S VALMSG="No State on file for Division "_$$GET1^DIQ(59,$$RXSITE^PSOBPSUT(RXIEN,0),.01) W $C(7)
 I '$$SPOK^PSOSPMUT(STATEIEN) D  Q
 . S VALMSG=$P($$SPOK^PSOSPMUT(STATEIEN),"^",2) W $C(7)
 D FULL^VALM1
 ;
 S SCREEN=$$SCREEN^PSOSPMUT(RXIEN,FILLNUM)
 I +SCREEN D  Q:$P(SCREEN,"^",3)="E"
 . W $C(7) I $P(SCREEN,"^",3)="E" S VALMSG=$P(SCREEN,"^",2) Q
 . W !!,"WARNING: ",$P(SCREEN,"^",2)
 ;
 K DIR S DIR("A")="Record Type"
 S DIR("L",1)="Enter the type of record to be sent for this prescription fill:"
 S DIR("L",2)=" "
 I $$RXRLDT^PSOBPSUT(RXIEN,FILLNUM) D
 . S DIR(0)="S^N:NEW;R:REVISE"
 . S DIR("L",3)="  N     NEW"
 . S DIR("L")="  R     REVISE"
 . S DIR("B")="NEW"
 E  D
 . S DIR(0)="S^V:VOID"
 . S DIR("L")="  V     VOID RECORD"
 . S DIR("B")="VOID"
 D ^DIR I $D(DUOUT)!($D(DIRUT)) K DIRUT,DUOUT,DIR Q
 S RECTYPE=Y
 ;
 W ! K DIR,DTOUT,DUOUT
 I (RECTYPE'="V")!(PSOASVER'="1995")!PSOTXRTS D
 . S DIR("A",1)="The Prescription Fill will be transmitted to the State",DIR("A",2)=""
 S DIR("A")="Confirm",DIR(0)="Y",DIR("B")="N"
 D ^DIR I $G(DTOUT)!$G(DUOUT)!'Y Q
 W ?40,"Please wait..."
 ;
 K ^TMP("PSOSPMRX",$J) S ^TMP("PSOSPMRX",$J,STATEIEN,RXIEN,FILLNUM)=RECTYPE
 S BATIEN=$$BLDBAT^PSOSPMU1($S(RECTYPE="V"&(PSOASVER="1995"):"VD",1:"RX"))
 ;
 I (($$GET1^DIQ(58.42,BATIEN,2,"I")="VD")&'PSOTXRTS) D
 . D EXMSG^PSOSPML2(1) W ! K %ZIS,IOP,POP,ZTSK S %ZIS="QM" D ^%ZIS K %ZIS Q:POP  U IO
 . W ! D EXPORT^PSOSPMUT(BATIEN,"VIEW")
 . D ^%ZISC N DIE,DA,DR S DIE="^PS(58.42,",DA=BATIEN
 . S DR="6///<Manual Web Upload>7////"_DUZ_";9///"_$$NOW^XLFDT()
 . D ^DIE
 E  D EXPORT^PSOSPMUT(BATIEN,"EXPORT")
 ;
 K DIR S DIR("A")="Press Return to continue",DIR(0)="E" D ^DIR
 Q
 ;
VIEW ; - Rx View Action
 N VALMCNT,PSOTITLE,DFN,PSOLSTLN
 S PSOTITLE=VALM("TITLE")
 ;
 ; DO structure used to avoid losing variables RXIEN,FILLNUM,LINE,PSOTITLE
 DO
 . N PSOVDA,DA,PS
 . S (PSOVDA,DA)=RXIEN
 . N RXIEN,FILLNUM,LINE,PSOTITLE D DP^PSORXVW
 ;
 S VALMBCK="R",VALM("TITLE")=PSOTITLE
 Q
 ;
MP ; - Patient Medication Profile
 N SITEIEN,PATIENT,SITE,DFN
 D FULL^VALM1 W !
 S SITEIEN=+$$RXSITE^PSOBPSUT(RXIEN,0) S:$G(PSOSITE) SITE=PSOSITE
 S PATIENT=+$$GET1^DIQ(52,RXIEN,2,"I")
 D LST^PSOPMP0(SITEIEN,PATIENT) S VALMBCK="R"
 Q
 ;
EXIT ; Listman Exit
 K ^TMP("PSOSPML4",$J)
 Q
HELP ; Listman Help
 Q
 ;
RXLKP(RXNUM) ; - Peforms Lookup on the PRESCRIPTION file
 N DIC,X,Y,D
 S DIC="^PSRX(",DIC(0)="QE",D="B",X=RXNUM
 D IX^DIC
 Q Y