- PSOCAN4 ;BIR/SAB - rx speed dc listman ;10/23/06 11:50am
- ;;7.0;OUTPATIENT PHARMACY;**20,24,27,63,88,117,131,259,268,225,358,385,391,508,617**;DEC 1997;Build 110
- ;External reference to File #200 supported by DBIA 224
- ;External reference NA^ORX1 supported by DBIA 2186
- ;External references to L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
- ;External reference to PSDRUG supported by DBIA 221
- ;External reference to PS(50.7 supported by DBIA 2223
- ;External reference to PS(50.606 supported by DBIA 2174
- ;External reference to ELIG^VADPT supported by DBIA 10061
- SEL I '$D(^XUSEC("PSORPH",DUZ)) S VALMSG="Unauthorized Action Selection.",VALMBCK="" Q
- N VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
- S DFNHLD=PSODFN
- S PSOPLCK=$$L^PSSLOCK(PSODFN,0) I '$G(PSOPLCK) D LOCK^PSOORCPY S VALMSG=$S($P($G(PSOPLCK),"^",2)'="":$P($G(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.") K PSOPLCK S VALMBCK="" Q
- K PSOPLCK S RXCNT=0 K PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR S LST=Y I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" D ULP Q
- K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT I +LST S (SPEED,PSOOELSE)=1 D D KCAN^PSOCAN3
- .S PSOCANRA=1 D RQTEST
- .; The PSOTRIC variable is needed by NOOR, which is called by COM^PSOCAN1, to determine the default Nature of Order.
- .N PSOTRIC S PSOTRIC=$$ELIG(PSODFN)
- .D FULL^VALM1,COM^PSOCAN1 I '$D(INCOM)!($D(DIRUT)) K SPEED S VALMBCK="R" Q
- .D FULL^VALM1 F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']"" S ORN=$P(LST,",",ORD) D @$S(+PSOLST(ORN)=52:"RX",1:"PEN")
- .S VALMBCK="R"
- I '$G(PSOOELSE) S VALMBCK=""
- D ^PSOBUILD,BLD^PSOORUT1,RV^PSOORFL K PSOMSG,RXCNT,DIR,DIRUT,DTOUT,DUOUT,LST,ORD,IEN,ORN,RPH,ST,REFL,REF,PSOACT,ORSV,PSORNW,PSORENW,PSONO,PSOCO,PSOCU,PSODIR,DSMSG,SAVORD,SAVORN,SPEED,DIRUT,PSONOOR
- D INVALD^PSOCAN1 K PSINV,PSOOELSE,INCOM,COM S PSODFN=DFNHLD K DFNHLD D ULP
- Q
- ULP D UL^PSSLOCK(+$G(PSODFN)) Q
- ;
- RX Q:'$D(^XUSEC("PSORPH",DUZ))
- N PSORXIEN
- S PSORXIEN=$P(PSOLST(ORN),"^",2)
- D PSOL^PSSLOCK(PSORXIEN) I '$G(PSOMSG) D D PAUSE^VALM1 K PSOMSG Q
- .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P($G(PSOMSG),"^",2),!,"Rx "_$P(^PSRX(PSORXIEN,0),"^"),! Q
- .W $C(7),!!,"Another person is editing Rx "_$P(^PSRX(PSORXIEN,0),"^"),!
- I $P($G(^PSRX(PSORXIEN,"PKI")),"^")!$P($G(^PSRX(PSORXIEN,"PKI")),"^",3),'$D(^XUSEC("PSDRPH",DUZ)) W $C(7),!!,"Digitally Signed Order - PSDRPH key required" D PAUSE^VALM1 Q
- S RXSP=1 K PSCAN S (EN,X)=$P(^PSRX(PSORXIEN,0),"^") S Y=PSORXIEN_"^"_X,Y(0,0)=X,Y(0)=$G(^PSRX(PSORXIEN,0)) D
- .I $P(^PSRX(+Y,"STA"),"^")=1!($P(^("STA"),"^")=4) D Q
- ..S:$G(PSONOOR)'="" PSONOORA=$G(PSONOOR) D DEL S:$G(PSONOORA)'="" PSONOOR=$G(PSONOORA) K PSONOORA Q
- .S YY=Y,YY(0,0)=Y(0,0),(PSODFN,DFN)=$P(Y(0),"^",2) D:$G(DFN) CHK^PSOCAN I DEAD!($P(^PSRX(+YY,"STA"),"^")>11),$P(^("STA"),"^")<16 S PSINV(EN)="" Q
- .S DA=+YY I $P($G(^PSRX(DA,"STA")),"^")=11!($P($G(^(2)),"^",6)<DT) D EXP^PSOCAN
- .S RX=YY(0,0) D:$D(^PSRX(DA,0)) SPEED1^PSOCAN1
- K YY I '$D(PSCAN) D PSOUL^PSSLOCK(PSORXIEN) Q
- S RX="",RXCNT=0 F S RX=$O(PSCAN(RX)) Q:RX="" S DA=+PSCAN(RX),REA=$P(PSCAN(RX),"^",2),RXCNT=RXCNT+1 D SHOW^PSOCAN1
- S RX="" F S RX=$O(PSCAN(RX)) Q:RX="" D ACT
- D PSOUL^PSSLOCK(PSORXIEN)
- Q
- ACT S DA=+PSCAN(RX),REA=$P(PSCAN(RX),"^",2),II=RX,PSODFN=$P(^PSRX(DA,0),"^",2) I REA="R" D REINS^PSOCAN2 Q
- D CAN1^PSOCAN3 Q
- PEN ;discontinue pending orders
- S SAVORD=ORD,SAVORN=ORN
- S ORD=$P(PSOLST(ORN),"^",2) D PSOL^PSSLOCK(+ORD_"S") I '$G(PSOMSG) D D MEDDIS K PSOMSG G OK
- .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P($G(PSOMSG),"^",2)_" (Pending order)",! Q
- .W $C(7),!!,"Another person is editing this Pending order.",!
- I $P(^PS(52.41,ORD,0),"^",24),'$D(^XUSEC("PSDRPH",DUZ)) W $C(7),!!,"Digitally Signed Order - PSDRPH key required" D PAUSE^VALM1 G OK
- I $P(^PS(52.41,ORD,0),"^",3)="RF" S DA=ORD,DIK="^PS(52.41," D ^DIK K DA,DIK D PSOUL^PSSLOCK(ORD_"S") Q
- K ^PS(52.41,"AOR",$P(^PS(52.41,ORD,0),"^",2),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD) S $P(^PS(52.41,ORD,0),"^",3)="DC"
- D EN^PSOHLSN(+^PS(52.41,ORD,0),"OC",INCOM,PSONOOR)
- D PSOUL^PSSLOCK(ORD_"S")
- OK S ORD=SAVORD,ORN=SAVORN Q
- NOOR ;ask nature of order
- N RX
- I '$D(PSOTRIC),$G(ORN) S RX=+$P($G(PSOLST(ORN)),U,2) I RX N PSOTRIC S PSOTRIC=$$TRIC^PSOREJP1(RX)
- D FULL^VALM1
- K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]"" D Q:$D(DIRUT) G NOORXP
- .S PSONOOR=$$NA^ORX1($S($G(PSOTRIC):"R",1:"S"),0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:""))
- .I +PSONOOR S PSONOOR=$P(PSONOOR,"^",3) Q
- .S DIRUT=1 K PSONOOR
- ;cnf, PSO*7*358, default to "SERVICE REJECTED" if TRICARE or CHAMPVA
- S DIR("A")="Nature of Order: ",DIR("B")=$S($G(PSOTRIC):"SERVICE REJECTED",$G(DODR):"SERVICE CORRECTED",1:"WRITTEN")
- S DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$S(+$G(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"")
- D ^DIR K DIR,DTOUT,DTOUT Q:$D(DIRUT) S PSONOOR=Y
- NOORXP I $G(PSOCANRA),'$G(PSOCANRZ) D REQ
- NOORX S:$D(DIRUT)&($G(SPEED)) VALMBCK="Q"
- Q
- DEL ;deletes non-verified Rxs
- ; PSO*7*508 - if this is an eRx being deleted, do not prompt the user since there is no user to reply
- ; - since this cancellation will be sent by the provider, PSONOOR is set to "E"
- I $D(ERXDCIEN) S Y="eRx Discontinued by external provider (eRx)." S PSOZVER=1,DA=$P(PSOLST(ORN),"^",2),PSONOOR="E" D ENQ^PSORXDL Q
- D FULL^VALM1
- W ! K DIR,DIRUT,DUOUT S DIR(0)="Y",DIR("B")="No",DIR("A",1)="Rx # "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")_" is in a Non-Verified Status.",DIR("A")="Are sure you want to mark the Rx as deleted" D ^DIR I 'Y!($D(DIRUT)) S VALMBCK="R" G EX
- I '$G(SPEED) D I $D(DIRUT) G EX
- .D NOOR I $D(DIRUT) S VALMSG="No Action Taken!",VALMBCK="R" Q
- .K DIR S DIR("A")="Comments",DIR("B")="Per Pharmacy Request",DIR(0)="F^5:100" D ^DIR K DIR I $D(DIRUT) S VALMSG="No Action Taken!" Q
- K PSDEL,PSORX("INTERVENE") S PSOZVER=1,DA=$P(PSOLST(ORN),"^",2)
- D ENQ^PSORXDL
- EX Q
- REQ ;prompt for requesting provider
- I '$G(PSOCANRD),$G(PSOCANRP),$G(ORD),$D(^PS(52.41,ORD,0)) S PSOCANRD=+$P($G(^PS(52.41,ORD,0)),"^",5)
- I $G(PSOCANRD) D
- .I $D(^VA(200,PSOCANRD,"PS")),$P($G(^("PS")),"^"),$S('$P(^("PS"),"^",4):1,1:$P(^("PS"),"^",4)'<DT) Q
- .K PSOCANRD
- W ! K DIC S DIC=200,DIC(0)="AEQMZ",DIC("A")="Requesting PROVIDER: ",DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)" I $G(PSOCANRD) S DIC("B")=PSOCANRD
- D ^DIC K DIC S:$G(Y)<0!($D(DTOUT))!($D(DUOUT)) DIRUT=1 I $G(Y) S PSOCANRC=+$G(Y),PSOCANRN=$P($G(Y),"^",2),PSOCANRZ=1
- Q
- RQTEST ;
- N PMIN,PMINZ,PMINFLAG
- S PMINFLAG=0 F PMIN=1:1:$L(LST,",") Q:$P(LST,",",PMIN)']"" S PMINZ=$P(LST,",",PMIN) D
- .I $P($G(PSOLST(PMINZ)),"^")=52 I $P($G(^PSRX(+$P($G(PSOLST(PMINZ)),"^",2),"STA")),"^")'=12,'$G(PMINFLAG) S PSOCANRD=+$P($G(^PSRX(+$P($G(PSOLST(PMINZ)),"^",2),0)),"^",4) S PMINFLAG=1
- .I $P($G(PSOLST(PMINZ)),"^")=52.41,'$G(PMINFLAG) S PSOCANRD=$P($G(^PS(52.41,+$P($G(PSOLST(PMINZ)),"^",2),0)),"^",5) S PMINFLAG=1
- I '$G(PMINFLAG) S PSOCANRZ=1
- Q
- MEDDIS ;
- N PSOFMMD
- Q:'$G(ORD)
- Q:'$D(^PS(52.41,ORD,0))
- I $P(^PS(52.41,ORD,0),"^",9) W "Drug: "_$P($G(^PSDRUG(+$P(^PS(52.41,ORD,0),"^",9),0)),"^") D PAUSE^VALM1 Q
- I $P(^PS(52.41,ORD,0),"^",8) S PSOFMMD=$P(^(0),"^",8) W "Orderable Item: "_$P($G(^PS(50.7,PSOFMMD,0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^PS(50.7,PSOFMMD,0)),"^",2),0)),"^") D PAUSE^VALM1
- Q
- ;
- REF ;CONT. FROM REF^PSOCAN2; PSO*7*259
- N PSOSIEN S PSOSIEN=0
- F S PSOSIEN=$O(^PS(52.5,"B",DA,PSOSIEN)) Q:'PSOSIEN D Q:PSONODEL
- .I $P($G(^PS(52.5,PSOSIEN,0)),"^",13)'=IFN Q ;NOT SAME REFILL
- .I '$P($G(^PS(52.5,PSOSIEN,"P")),"^") Q ;SUSPENSE LABEL PRINT
- .S PSONODEL=1 ;REFILL NODE SHOULD NOT BE DELETED
- Q
- ;
- ELIG(DFN) ; Return primary eligibility
- ; Input:
- ; DFN: Patient IEN (required)
- ; Output:
- ; "": No DFN passed in, 0: Veteran, 1: TRICARE, 2: CHAMPVA
- I '$G(DFN) Q ""
- ; Variables VAEL, VAERR, and I are modified by ELIG^VADPT
- N VAEL,VAERR,I,ELIG
- ; ELIG^VADPT assumes DFN is defined and returns arrays VAEL and VAERR
- D ELIG^VADPT ; Supported by IA 10061
- ; VAEL(1) contains the primary eligibility
- S ELIG=$P($G(VAEL(1)),U,2)
- Q $S(ELIG="TRICARE"!(ELIG="SHARING AGREEMENT"):1,ELIG="CHAMPVA":2,1:0)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCAN4 8345 printed Jan 18, 2025@03:26:24 Page 2
- PSOCAN4 ;BIR/SAB - rx speed dc listman ;10/23/06 11:50am
- +1 ;;7.0;OUTPATIENT PHARMACY;**20,24,27,63,88,117,131,259,268,225,358,385,391,508,617**;DEC 1997;Build 110
- +2 ;External reference to File #200 supported by DBIA 224
- +3 ;External reference NA^ORX1 supported by DBIA 2186
- +4 ;External references to L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
- +5 ;External reference to PSDRUG supported by DBIA 221
- +6 ;External reference to PS(50.7 supported by DBIA 2223
- +7 ;External reference to PS(50.606 supported by DBIA 2174
- +8 ;External reference to ELIG^VADPT supported by DBIA 10061
- SEL IF '$DATA(^XUSEC("PSORPH",DUZ))
- SET VALMSG="Unauthorized Action Selection."
- SET VALMBCK=""
- QUIT
- +1 NEW VALMCNT
- IF '$GET(PSOCNT)
- SET VALMSG="This patient has no Prescriptions!"
- SET VALMBCK=""
- QUIT
- +2 SET DFNHLD=PSODFN
- +3 SET PSOPLCK=$$L^PSSLOCK(PSODFN,0)
- IF '$GET(PSOPLCK)
- DO LOCK^PSOORCPY
- SET VALMSG=$SELECT($PIECE($GET(PSOPLCK),"^",2)'="":$PIECE($GET(PSOPLCK),"^",2)_" is working on this patient.",1:"Another person is entering orders for this patient.")
- KILL PSOPLCK
- SET VALMBCK=""
- QUIT
- +4 KILL PSOPLCK
- SET RXCNT=0
- KILL PSOFDR,DIR,DUOUT,DIRUT
- SET DIR("A")="Select Orders by number"
- SET DIR(0)="LO^1:"_PSOCNT
- DO ^DIR
- SET LST=Y
- IF $DATA(DTOUT)!($DATA(DUOUT))
- KILL DIR,DIRUT,DTOUT,DUOUT
- SET VALMBCK=""
- DO ULP
- QUIT
- +5 KILL DIR,DIRUT,DTOUT,PSOOELSE,DTOUT
- IF +LST
- SET (SPEED,PSOOELSE)=1
- Begin DoDot:1
- +6 SET PSOCANRA=1
- DO RQTEST
- +7 ; The PSOTRIC variable is needed by NOOR, which is called by COM^PSOCAN1, to determine the default Nature of Order.
- +8 NEW PSOTRIC
- SET PSOTRIC=$$ELIG(PSODFN)
- +9 DO FULL^VALM1
- DO COM^PSOCAN1
- IF '$DATA(INCOM)!($DATA(DIRUT))
- KILL SPEED
- SET VALMBCK="R"
- QUIT
- +10 DO FULL^VALM1
- FOR ORD=1:1:$LENGTH(LST,",")
- if $PIECE(LST,",",ORD)']""
- QUIT
- SET ORN=$PIECE(LST,",",ORD)
- DO @$SELECT(+PSOLST(ORN)=52:"RX",1:"PEN")
- +11 SET VALMBCK="R"
- End DoDot:1
- DO KCAN^PSOCAN3
- +12 IF '$GET(PSOOELSE)
- SET VALMBCK=""
- +13 DO ^PSOBUILD
- DO BLD^PSOORUT1
- DO RV^PSOORFL
- KILL PSOMSG,RXCNT,DIR,DIRUT,DTOUT,DUOUT,LST,ORD,IEN,ORN,RPH,ST,REFL,REF,PSOACT,ORSV,PSORNW,PSORENW,PSONO,PSOCO,PSOCU,PSODIR,DSMSG,SAVORD,SAVORN,SPEED,DIRUT,PSONOOR
- +14 DO INVALD^PSOCAN1
- KILL PSINV,PSOOELSE,INCOM,COM
- SET PSODFN=DFNHLD
- KILL DFNHLD
- DO ULP
- +15 QUIT
- ULP DO UL^PSSLOCK(+$GET(PSODFN))
- QUIT
- +1 ;
- RX if '$DATA(^XUSEC("PSORPH",DUZ))
- QUIT
- +1 NEW PSORXIEN
- +2 SET PSORXIEN=$PIECE(PSOLST(ORN),"^",2)
- +3 DO PSOL^PSSLOCK(PSORXIEN)
- IF '$GET(PSOMSG)
- Begin DoDot:1
- +4 IF $PIECE($GET(PSOMSG),"^",2)'=""
- WRITE $CHAR(7),!!,$PIECE($GET(PSOMSG),"^",2),!,"Rx "_$PIECE(^PSRX(PSORXIEN,0),"^"),!
- QUIT
- +5 WRITE $CHAR(7),!!,"Another person is editing Rx "_$PIECE(^PSRX(PSORXIEN,0),"^"),!
- End DoDot:1
- DO PAUSE^VALM1
- KILL PSOMSG
- QUIT
- +6 IF $PIECE($GET(^PSRX(PSORXIEN,"PKI")),"^")!$PIECE($GET(^PSRX(PSORXIEN,"PKI")),"^",3)
- IF '$DATA(^XUSEC("PSDRPH",DUZ))
- WRITE $CHAR(7),!!,"Digitally Signed Order - PSDRPH key required"
- DO PAUSE^VALM1
- QUIT
- +7 SET RXSP=1
- KILL PSCAN
- SET (EN,X)=$PIECE(^PSRX(PSORXIEN,0),"^")
- SET Y=PSORXIEN_"^"_X
- SET Y(0,0)=X
- SET Y(0)=$GET(^PSRX(PSORXIEN,0))
- Begin DoDot:1
- +8 IF $PIECE(^PSRX(+Y,"STA"),"^")=1!($PIECE(^("STA"),"^")=4)
- Begin DoDot:2
- +9 if $GET(PSONOOR)'=""
- SET PSONOORA=$GET(PSONOOR)
- DO DEL
- if $GET(PSONOORA)'=""
- SET PSONOOR=$GET(PSONOORA)
- KILL PSONOORA
- QUIT
- End DoDot:2
- QUIT
- +10 SET YY=Y
- SET YY(0,0)=Y(0,0)
- SET (PSODFN,DFN)=$PIECE(Y(0),"^",2)
- if $GET(DFN)
- DO CHK^PSOCAN
- IF DEAD!($PIECE(^PSRX(+YY,"STA"),"^")>11)
- IF $PIECE(^("STA"),"^")<16
- SET PSINV(EN)=""
- QUIT
- +11 SET DA=+YY
- IF $PIECE($GET(^PSRX(DA,"STA")),"^")=11!($PIECE($GET(^(2)),"^",6)<DT)
- DO EXP^PSOCAN
- +12 SET RX=YY(0,0)
- if $DATA(^PSRX(DA,0))
- DO SPEED1^PSOCAN1
- End DoDot:1
- +13 KILL YY
- IF '$DATA(PSCAN)
- DO PSOUL^PSSLOCK(PSORXIEN)
- QUIT
- +14 SET RX=""
- SET RXCNT=0
- FOR
- SET RX=$ORDER(PSCAN(RX))
- if RX=""
- QUIT
- SET DA=+PSCAN(RX)
- SET REA=$PIECE(PSCAN(RX),"^",2)
- SET RXCNT=RXCNT+1
- DO SHOW^PSOCAN1
- +15 SET RX=""
- FOR
- SET RX=$ORDER(PSCAN(RX))
- if RX=""
- QUIT
- DO ACT
- +16 DO PSOUL^PSSLOCK(PSORXIEN)
- +17 QUIT
- ACT SET DA=+PSCAN(RX)
- SET REA=$PIECE(PSCAN(RX),"^",2)
- SET II=RX
- SET PSODFN=$PIECE(^PSRX(DA,0),"^",2)
- IF REA="R"
- DO REINS^PSOCAN2
- QUIT
- +1 DO CAN1^PSOCAN3
- QUIT
- PEN ;discontinue pending orders
- +1 SET SAVORD=ORD
- SET SAVORN=ORN
- +2 SET ORD=$PIECE(PSOLST(ORN),"^",2)
- DO PSOL^PSSLOCK(+ORD_"S")
- IF '$GET(PSOMSG)
- Begin DoDot:1
- +3 IF $PIECE($GET(PSOMSG),"^",2)'=""
- WRITE $CHAR(7),!!,$PIECE($GET(PSOMSG),"^",2)_" (Pending order)",!
- QUIT
- +4 WRITE $CHAR(7),!!,"Another person is editing this Pending order.",!
- End DoDot:1
- DO MEDDIS
- KILL PSOMSG
- GOTO OK
- +5 IF $PIECE(^PS(52.41,ORD,0),"^",24)
- IF '$DATA(^XUSEC("PSDRPH",DUZ))
- WRITE $CHAR(7),!!,"Digitally Signed Order - PSDRPH key required"
- DO PAUSE^VALM1
- GOTO OK
- +6 IF $PIECE(^PS(52.41,ORD,0),"^",3)="RF"
- SET DA=ORD
- SET DIK="^PS(52.41,"
- DO ^DIK
- KILL DA,DIK
- DO PSOUL^PSSLOCK(ORD_"S")
- QUIT
- +7 KILL ^PS(52.41,"AOR",$PIECE(^PS(52.41,ORD,0),"^",2),+$PIECE($GET(^PS(52.41,ORD,"INI")),"^"),ORD)
- SET $PIECE(^PS(52.41,ORD,0),"^",3)="DC"
- +8 DO EN^PSOHLSN(+^PS(52.41,ORD,0),"OC",INCOM,PSONOOR)
- +9 DO PSOUL^PSSLOCK(ORD_"S")
- OK SET ORD=SAVORD
- SET ORN=SAVORN
- QUIT
- NOOR ;ask nature of order
- +1 NEW RX
- +2 IF '$DATA(PSOTRIC)
- IF $GET(ORN)
- SET RX=+$PIECE($GET(PSOLST(ORN)),U,2)
- IF RX
- NEW PSOTRIC
- SET PSOTRIC=$$TRIC^PSOREJP1(RX)
- +3 DO FULL^VALM1
- +4 KILL DIR,DTOUT,DTOUT,DIRUT
- IF $TEXT(NA^ORX1)]""
- Begin DoDot:1
- +5 SET PSONOOR=$$NA^ORX1($SELECT($GET(PSOTRIC):"R",1:"S"),0,"B","Nature of Order",0,"WPSDIVR"_$SELECT(+$GET(^VA(200,DUZ,"PS")):"E",1:""))
- +6 IF +PSONOOR
- SET PSONOOR=$PIECE(PSONOOR,"^",3)
- QUIT
- +7 SET DIRUT=1
- KILL PSONOOR
- End DoDot:1
- if $DATA(DIRUT)
- QUIT
- GOTO NOORXP
- +8 ;cnf, PSO*7*358, default to "SERVICE REJECTED" if TRICARE or CHAMPVA
- +9 SET DIR("A")="Nature of Order: "
- SET DIR("B")=$SELECT($GET(PSOTRIC):"SERVICE REJECTED",$GET(DODR):"SERVICE CORRECTED",1:"WRITTEN")
- +10 SET DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$SELECT(+$GET(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"")
- +11 DO ^DIR
- KILL DIR,DTOUT,DTOUT
- if $DATA(DIRUT)
- QUIT
- SET PSONOOR=Y
- NOORXP IF $GET(PSOCANRA)
- IF '$GET(PSOCANRZ)
- DO REQ
- NOORX if $DATA(DIRUT)&($GET(SPEED))
- SET VALMBCK="Q"
- +1 QUIT
- DEL ;deletes non-verified Rxs
- +1 ; PSO*7*508 - if this is an eRx being deleted, do not prompt the user since there is no user to reply
- +2 ; - since this cancellation will be sent by the provider, PSONOOR is set to "E"
- +3 IF $DATA(ERXDCIEN)
- SET Y="eRx Discontinued by external provider (eRx)."
- SET PSOZVER=1
- SET DA=$PIECE(PSOLST(ORN),"^",2)
- SET PSONOOR="E"
- DO ENQ^PSORXDL
- QUIT
- +4 DO FULL^VALM1
- +5 WRITE !
- KILL DIR,DIRUT,DUOUT
- SET DIR(0)="Y"
- SET DIR("B")="No"
- SET DIR("A",1)="Rx # "_$PIECE(^PSRX($PIECE(PSOLST(ORN),"^",2),0),"^")_" is in a Non-Verified Status."
- SET DIR("A")="Are sure you want to mark the Rx as deleted"
- DO ^DIR
- IF 'Y!($DATA(DIRUT))
- SET VALMBCK="R"
- GOTO EX
- +6 IF '$GET(SPEED)
- Begin DoDot:1
- +7 DO NOOR
- IF $DATA(DIRUT)
- SET VALMSG="No Action Taken!"
- SET VALMBCK="R"
- QUIT
- +8 KILL DIR
- SET DIR("A")="Comments"
- SET DIR("B")="Per Pharmacy Request"
- SET DIR(0)="F^5:100"
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- SET VALMSG="No Action Taken!"
- QUIT
- End DoDot:1
- IF $DATA(DIRUT)
- GOTO EX
- +9 KILL PSDEL,PSORX("INTERVENE")
- SET PSOZVER=1
- SET DA=$PIECE(PSOLST(ORN),"^",2)
- +10 DO ENQ^PSORXDL
- EX QUIT
- REQ ;prompt for requesting provider
- +1 IF '$GET(PSOCANRD)
- IF $GET(PSOCANRP)
- IF $GET(ORD)
- IF $DATA(^PS(52.41,ORD,0))
- SET PSOCANRD=+$PIECE($GET(^PS(52.41,ORD,0)),"^",5)
- +2 IF $GET(PSOCANRD)
- Begin DoDot:1
- +3 IF $DATA(^VA(200,PSOCANRD,"PS"))
- IF $PIECE($GET(^("PS")),"^")
- IF $SELECT('$PIECE(^("PS"),"^",4):1,1:$PIECE(^("PS"),"^",4)'<DT)
- QUIT
- +4 KILL PSOCANRD
- End DoDot:1
- +5 WRITE !
- KILL DIC
- SET DIC=200
- SET DIC(0)="AEQMZ"
- SET DIC("A")="Requesting PROVIDER: "
- SET DIC("S")="I $D(^(""PS"")),$P(^(""PS""),""^""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)'<DT)"
- IF $GET(PSOCANRD)
- SET DIC("B")=PSOCANRD
- +6 DO ^DIC
- KILL DIC
- if $GET(Y)<0!($DATA(DTOUT))!($DATA(DUOUT))
- SET DIRUT=1
- IF $GET(Y)
- SET PSOCANRC=+$GET(Y)
- SET PSOCANRN=$PIECE($GET(Y),"^",2)
- SET PSOCANRZ=1
- +7 QUIT
- RQTEST ;
- +1 NEW PMIN,PMINZ,PMINFLAG
- +2 SET PMINFLAG=0
- FOR PMIN=1:1:$LENGTH(LST,",")
- if $PIECE(LST,",",PMIN)']""
- QUIT
- SET PMINZ=$PIECE(LST,",",PMIN)
- Begin DoDot:1
- +3 IF $PIECE($GET(PSOLST(PMINZ)),"^")=52
- IF $PIECE($GET(^PSRX(+$PIECE($GET(PSOLST(PMINZ)),"^",2),"STA")),"^")'=12
- IF '$GET(PMINFLAG)
- SET PSOCANRD=+$PIECE($GET(^PSRX(+$PIECE($GET(PSOLST(PMINZ)),"^",2),0)),"^",4)
- SET PMINFLAG=1
- +4 IF $PIECE($GET(PSOLST(PMINZ)),"^")=52.41
- IF '$GET(PMINFLAG)
- SET PSOCANRD=$PIECE($GET(^PS(52.41,+$PIECE($GET(PSOLST(PMINZ)),"^",2),0)),"^",5)
- SET PMINFLAG=1
- End DoDot:1
- +5 IF '$GET(PMINFLAG)
- SET PSOCANRZ=1
- +6 QUIT
- MEDDIS ;
- +1 NEW PSOFMMD
- +2 if '$GET(ORD)
- QUIT
- +3 if '$DATA(^PS(52.41,ORD,0))
- QUIT
- +4 IF $PIECE(^PS(52.41,ORD,0),"^",9)
- WRITE "Drug: "_$PIECE($GET(^PSDRUG(+$PIECE(^PS(52.41,ORD,0),"^",9),0)),"^")
- DO PAUSE^VALM1
- QUIT
- +5 IF $PIECE(^PS(52.41,ORD,0),"^",8)
- SET PSOFMMD=$PIECE(^(0),"^",8)
- WRITE "Orderable Item: "_$PIECE($GET(^PS(50.7,PSOFMMD,0)),"^")_" "_$PIECE($GET(^PS(50.606,+$PIECE($GET(^PS(50.7,PSOFMMD,0)),"^",2),0)),"^")
- DO PAUSE^VALM1
- +6 QUIT
- +7 ;
- REF ;CONT. FROM REF^PSOCAN2; PSO*7*259
- +1 NEW PSOSIEN
- SET PSOSIEN=0
- +2 FOR
- SET PSOSIEN=$ORDER(^PS(52.5,"B",DA,PSOSIEN))
- if 'PSOSIEN
- QUIT
- Begin DoDot:1
- +3 ;NOT SAME REFILL
- IF $PIECE($GET(^PS(52.5,PSOSIEN,0)),"^",13)'=IFN
- QUIT
- +4 ;SUSPENSE LABEL PRINT
- IF '$PIECE($GET(^PS(52.5,PSOSIEN,"P")),"^")
- QUIT
- +5 ;REFILL NODE SHOULD NOT BE DELETED
- SET PSONODEL=1
- End DoDot:1
- if PSONODEL
- QUIT
- +6 QUIT
- +7 ;
- ELIG(DFN) ; Return primary eligibility
- +1 ; Input:
- +2 ; DFN: Patient IEN (required)
- +3 ; Output:
- +4 ; "": No DFN passed in, 0: Veteran, 1: TRICARE, 2: CHAMPVA
- +5 IF '$GET(DFN)
- QUIT ""
- +6 ; Variables VAEL, VAERR, and I are modified by ELIG^VADPT
- +7 NEW VAEL,VAERR,I,ELIG
- +8 ; ELIG^VADPT assumes DFN is defined and returns arrays VAEL and VAERR
- +9 ; Supported by IA 10061
- DO ELIG^VADPT
- +10 ; VAEL(1) contains the primary eligibility
- +11 SET ELIG=$PIECE($GET(VAEL(1)),U,2)
- +12 QUIT $SELECT(ELIG="TRICARE"!(ELIG="SHARING AGREEMENT"):1,ELIG="CHAMPVA":2,1:0)