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