PSOSPML4 ;BIRM/MFR - Single Prescription ASAP Data Listman Driver ;09/01/12
;;7.0;OUTPATIENT PHARMACY;**408,451,625,659,662,770**;DEC 1997;Build 145
;
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
; Most of these variables most be NEWed because they are being killed by PSORXVW
N VALMCNT,PSOTITLE,PSOLSTLN,QUIT,DIR,DIRUT,DIROUT,Y,X,XX,BPSVRX,PSODFN,DFN,RX2
N ST,RFL,RFLL,RFL1,ST,II,J,N,PHYS,L1,DIRUT,PSDIV,PSEXDT,MED,M1,FFX,DTT,DAT,RX0
N LBL,I,RFDATE,%H,%I,RN,RFT,%,%I,DFN,GMRA,GMRAL,HDR,POERR,PTST,REFL,RF,RLD,RX3
N RXN,RXOR,SG,VA,VADM,VAERR,VALMBCK,VAPA,X,DIC,REA,ZD,PSOHD,PSOBCK,PSODFN,QUIT
N Z0,Z1,EXDT,IFN,DIR,DUOUT,DTOUT,PSOELSE,R3,RTN,SIG,STA,P1,PL,P0
;
S PSOTITLE=VALM("TITLE")
;
; DO structure used to avoid losing variables RXIEN,FILLNUM,LINE,PSOTITLE
DO
. N PSOVDA,DA,PS
. S (PSOVDA,DA)=RXIEN,BPSVRX=0,PS="REJECT"
. 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 12447 printed Sep 23, 2025@20:11:31 Page 2
PSOSPML4 ;BIRM/MFR - Single Prescription ASAP Data Listman Driver ;09/01/12
+1 ;;7.0;OUTPATIENT PHARMACY;**408,451,625,659,662,770**;DEC 1997;Build 145
+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 ; Most of these variables most be NEWed because they are being killed by PSORXVW
+2 NEW VALMCNT,PSOTITLE,PSOLSTLN,QUIT,DIR,DIRUT,DIROUT,Y,X,XX,BPSVRX,PSODFN,DFN,RX2
+3 NEW ST,RFL,RFLL,RFL1,ST,II,J,N,PHYS,L1,DIRUT,PSDIV,PSEXDT,MED,M1,FFX,DTT,DAT,RX0
+4 NEW LBL,I,RFDATE,%H,%I,RN,RFT,%,%I,DFN,GMRA,GMRAL,HDR,POERR,PTST,REFL,RF,RLD,RX3
+5 NEW RXN,RXOR,SG,VA,VADM,VAERR,VALMBCK,VAPA,X,DIC,REA,ZD,PSOHD,PSOBCK,PSODFN,QUIT
+6 NEW Z0,Z1,EXDT,IFN,DIR,DUOUT,DTOUT,PSOELSE,R3,RTN,SIG,STA,P1,PL,P0
+7 ;
+8 SET PSOTITLE=VALM("TITLE")
+9 ;
+10 ; DO structure used to avoid losing variables RXIEN,FILLNUM,LINE,PSOTITLE
+11 Begin DoDot:1
+12 NEW PSOVDA,DA,PS
+13 SET (PSOVDA,DA)=RXIEN
SET BPSVRX=0
SET PS="REJECT"
+14 NEW RXIEN,FILLNUM,LINE,PSOTITLE
DO DP^PSORXVW
End DoDot:1
+15 ;
+16 SET VALMBCK="R"
SET VALM("TITLE")=PSOTITLE
+17 QUIT
+18 ;
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
