PSOCAN4 ;BIR/SAB-rx speed dc listman ;05-Jun-2013 15:40;DU
;;7.0;OUTPATIENT PHARMACY;**20,24,27,63,88,117,131,1005,259,268,225,1015,1017**;DEC 1997;Build 40
;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
; Modified - IHS/MSC/PLS - 11/27/06 - Line PEN+1 Added NEW statement for ORD
; 06/05/13 - Line NOOR+3
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
.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))
D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) 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($P(PSOLST(ORN),"^",2),0),"^"),! Q
.W $C(7),!!,"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^"),!
S RXSP=1 K PSCAN S (EN,X)=$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^") S Y=$P(PSOLST(ORN),"^",2)_"^"_X,Y(0,0)=X,Y(0)=$G(^PSRX($P(PSOLST(ORN),"^",2),0)) D
.I $P(^PSRX(+Y,"STA"),"^")=1!($P(^("STA"),"^")=4) D Q
..I $P($G(^PSRX(+Y,"PKI")),"^") N PKI,PKI1,PKIR,PKIE,DA S DA=+Y D CER^PSOPKIV1
..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($P(PSOLST(ORN),"^",2)) 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($P(PSOLST(ORN),"^",2))
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
N ORD ; IHS/MSC/PLS - 11/27/06
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),"^",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 ;IHS/MSC/PLS - 11/27/06
Q
NOOR ;ask nature of order
D FULL^VALM1
K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]"" D Q:$D(DIRUT) G NOORXP
.;IHS/MSC/PLS - 06/05/2013
.;S PSONOOR=$$NA^ORX1("S",0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:""))
.S PSONOOR=$$NA^ORX1("S",0,"B","Nature of Order",0,"WPSDIV"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:""))
.I +PSONOOR S PSONOOR=$P(PSONOOR,"^",3) Q
.S DIRUT=1 K PSONOOR
S DIR("A")="Nature of Order: ",DIR("B")=$S($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
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^PSOCAN4 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)
I $G(PKI1) N INCOM S INCOM=Y D DCV^PSOPKIV1 Q
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
PSOCAN4 ;BIR/SAB-rx speed dc listman ;05-Jun-2013 15:40;DU
+1 ;;7.0;OUTPATIENT PHARMACY;**20,24,27,63,88,117,131,1005,259,268,225,1015,1017**;DEC 1997;Build 40
+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 ; Modified - IHS/MSC/PLS - 11/27/06 - Line PEN+1 Added NEW statement for ORD
+9 ; 06/05/13 - Line NOOR+3
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 DO FULL^VALM1
DO COM^PSOCAN1
IF '$DATA(INCOM)!($DATA(DIRUT))
KILL SPEED
SET VALMBCK="R"
QUIT
+8 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")
+9 SET VALMBCK="R"
End DoDot:1
DO KCAN^PSOCAN3
+10 IF '$GET(PSOOELSE)
SET VALMBCK=""
+11 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
+12 DO INVALD^PSOCAN1
KILL PSINV,PSOOELSE,INCOM,COM
SET PSODFN=DFNHLD
KILL DFNHLD
DO ULP
+13 QUIT
ULP DO UL^PSSLOCK(+$GET(PSODFN))
QUIT
+1 ;
RX IF '$DATA(^XUSEC("PSORPH",DUZ))
QUIT
+1 DO PSOL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
IF '$GET(PSOMSG)
Begin DoDot:1
+2 IF $PIECE($GET(PSOMSG),"^",2)'=""
WRITE $CHAR(7),!!,$PIECE($GET(PSOMSG),"^",2),!,"Rx "_$PIECE(^PSRX($PIECE(PSOLST(ORN),"^",2),0),"^"),!
QUIT
+3 WRITE $CHAR(7),!!,"Another person is editing Rx "_$PIECE(^PSRX($PIECE(PSOLST(ORN),"^",2),0),"^"),!
End DoDot:1
DO PAUSE^VALM1
KILL PSOMSG
QUIT
+4 SET RXSP=1
KILL PSCAN
SET (EN,X)=$PIECE(^PSRX($PIECE(PSOLST(ORN),"^",2),0),"^")
SET Y=$PIECE(PSOLST(ORN),"^",2)_"^"_X
SET Y(0,0)=X
SET Y(0)=$GET(^PSRX($PIECE(PSOLST(ORN),"^",2),0))
Begin DoDot:1
+5 IF $PIECE(^PSRX(+Y,"STA"),"^")=1!($PIECE(^("STA"),"^")=4)
Begin DoDot:2
+6 IF $PIECE($GET(^PSRX(+Y,"PKI")),"^")
NEW PKI,PKI1,PKIR,PKIE,DA
SET DA=+Y
DO CER^PSOPKIV1
+7 IF $GET(PSONOOR)'=""
SET PSONOORA=$GET(PSONOOR)
DO DEL
IF $GET(PSONOORA)'=""
SET PSONOOR=$GET(PSONOORA)
KILL PSONOORA
QUIT
End DoDot:2
QUIT
+8 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
+9 SET DA=+YY
IF $PIECE($GET(^PSRX(DA,"STA")),"^")=11!($PIECE($GET(^(2)),"^",6)<DT)
DO EXP^PSOCAN
+10 SET RX=YY(0,0)
IF $DATA(^PSRX(DA,0))
DO SPEED1^PSOCAN1
End DoDot:1
+11 KILL YY
IF '$DATA(PSCAN)
DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
QUIT
+12 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
+13 SET RX=""
FOR
SET RX=$ORDER(PSCAN(RX))
IF RX=""
QUIT
DO ACT
+14 DO PSOUL^PSSLOCK($PIECE(PSOLST(ORN),"^",2))
+15 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 ;S SAVORD=ORD,SAVORN=ORN
+2 ; IHS/MSC/PLS - 11/27/06
NEW ORD
+3 SET ORD=$PIECE(PSOLST(ORN),"^",2)
DO PSOL^PSSLOCK(+ORD_"S")
IF '$GET(PSOMSG)
Begin DoDot:1
+4 IF $PIECE($GET(PSOMSG),"^",2)'=""
WRITE $CHAR(7),!!,$PIECE($GET(PSOMSG),"^",2)_" (Pending order)",!
QUIT
+5 WRITE $CHAR(7),!!,"Another person is editing this Pending order.",!
End DoDot:1
DO MEDDIS
KILL PSOMSG
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 ;S ORD=SAVORD,ORN=SAVORN ;IHS/MSC/PLS - 11/27/06
+1 QUIT
NOOR ;ask nature of order
+1 DO FULL^VALM1
+2 KILL DIR,DTOUT,DTOUT,DIRUT
IF $TEXT(NA^ORX1)]""
Begin DoDot:1
+3 ;IHS/MSC/PLS - 06/05/2013
+4 ;S PSONOOR=$$NA^ORX1("S",0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:""))
+5 SET PSONOOR=$$NA^ORX1("S",0,"B","Nature of Order",0,"WPSDIV"_$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 SET DIR("A")="Nature of Order: "
SET DIR("B")=$SELECT($GET(DODR):"SERVICE CORRECTED",1:"WRITTEN")
+9 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:"")
+10 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 DO FULL^VALM1
+2 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
+3 IF '$GET(SPEED)
Begin DoDot:1
+4 DO NOOR^PSOCAN4
IF $DATA(DIRUT)
SET VALMSG="No Action Taken!"
SET VALMBCK="R"
QUIT
+5 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
+6 KILL PSDEL,PSORX("INTERVENE")
SET PSOZVER=1
SET DA=$PIECE(PSOLST(ORN),"^",2)
+7 IF $GET(PKI1)
NEW INCOM
SET INCOM=Y
DO DCV^PSOPKIV1
QUIT
+8 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
