PSGPLF ;BIR/CML3-FILES AWAY PICK LIST DATA (BACKGROUND JOB) ;29 SEP 97 / 12:40 PM
;;5.0; INPATIENT MEDICATIONS ;**84,130,168**;16 DEC 97
;
; Reference to ^PS(55 is supported by DBIA# 2191.
; Reference to ^PSDRUG is supported by DBIA# 2192.
; Reference to ^ECXUD1 is supported by DBIA# 172.
; Reference to ^DIC(42 is supported by DBIA# 1377.
; Reference to ^DIC(42 is supported by DBIA# 10039.
;
FILE ; add data to cost file and order
S PSGX=$P(PLR,"^",2),PSGY=$P(PLR,"^",3) S:PSGX?7N1"DI" PSGX=0 S PSGX=+PSGX S:PSGY="" $P(PLR,"^",3)=PSGX,PSGY=PSGX
S COST="",(D3,DO)=$P(PLR,"^") I $G(D3) Q:'$D(^PS(55,PN,5,O,1,D3,0))
I D3=+D3 S D3=$P($G(^PS(55,PN,5,O,1,D3,0)),"^") I D3=+D3 S COST=$P($G(^PSDRUG(D3,660)),"^",6)
E S D3="999Z"
I COST="" S PSGPLFF=0 S:D3="999Z" D3=PN_","_O_","_DO S:'$D(^TMP("PSGNCF",$J,"B",D3)) ^(D3)="" Q
S PS=PSGY<0*2 S:PS PSGY=-PSGY S COST=COST*PSGY G:'PSGY&'COST OS
F L +^PS(57.6,D0,1,D1,1,D2,1,D3,0):1 I Q
I $D(^PS(57.6,D0,1,D1,1,D2,1,D3,0)) S ND=^(0),PSGZ=1
E S ND=D3,PSGZ=0
S $P(ND,"^",2+PS)=$P(ND,"^",2+PS)+PSGY,$P(ND,"^",3+PS)=$P(ND,"^",3+PS)+COST,^PS(57.6,D0,1,D1,1,D2,1,D3,0)=ND L -^PS(57.6,D0,1,D1,1,D2,1,D3,0)
G:PSGZ OS
F L +^PS(57.6,D0,1,D1,1,D2,1,0):1 I S ND=$G(^PS(57.6,D0,1,D1,1,D2,1,0)) S:ND="" ND="^57.63P^" S $P(ND,"^",3)=D3,$P(ND,"^",4)=$P(ND,"^",4)+1 S ^(0)=ND L -^PS(57.6,D0,1,D1,1,D2,1,0) Q
I '$D(^PS(57.6,D0,1,D1,1,D2,0)) F L +^PS(57.6,D0,1,D1,1,0):1 I S ND=$G(^PS(57.6,D0,1,D1,1,0)) S:ND="" ND="^57.62P" S $P(ND,"^",3)=D2,$P(ND,"^",4)=$P(ND,"^",4)+1 S ^(0)=ND L -^PS(57.6,D0,1,D1,1,0) Q
;
OS ;
I PSGX!PSGY F L +^PS(55,PN,5,O,1,DO,0):1 I S PSGZ=$G(^PS(55,PN,5,O,1,DO,0)),$P(PSGZ,"^",5)=$P(PSGZ,"^",5)+PSGX,$P(PSGZ,"^",PS>0+6)=$P(PSGZ,"^",PS>0+6)+PSGY,^(0)=PSGZ L -^PS(55,PN,5,O,1,DO,0) Q
N PSGSTRT S PSGSTRT=$P($G(^PS(55,PN,5,O,2)),"^",2)
I PSGY,D0=+D0,D1=+D1,D2=+D2,D3=+D3 S:PS PSGY=-PSGY,COST=-COST D ENPLF^PSGAMSA(PN,O,D3,PSGY,COST,1,D1,D2,D0) S X="ECXUD1" X ^%ZOSF("TEST") I S ECUD=PN_"^"_D0_"^"_D3_"^"_PSGY_"^"_D1_"^"_D2_";200^"_COST_"^"_PSGSTRT_"^"_$G(O) D ^ECXUD1
S $P(PLR,"^",4)=1,^PS(53.5,G,1,PN,1,$P(PD,"^",2),1,$P(DD,"^",2),0)=PLR
Q
;
GD1 ; get next (second) level (ward) in 57.6
S WH=WD,D1=$O(^DIC(42,"B",WD,0)) S:'D1 D1="999Z" Q:$D(^PS(57.6,D0,1,D1))
F L +^PS(57.6,D0,1,0):1 I S ND=$G(^PS(57.6,D0,1,0)) S:ND="" ND="^57.61PA" S $P(ND,"^",3)=D1 S:'$D(^(D1)) $P(ND,"^",4)=$P(ND,"^",4)+1 S ^(0)=ND,^(D1,0)=D1 L -^PS(57.6,D0,1,0) Q
Q
;
EN ; action starts here
N G,T,W,R,P,S,PD,DD,DDRG D NOW^%DTC S PSGDT=%,G=0 K C,^TMP("PSGNCF",$J)
F S G=$O(^PS(53.5,"AF",G)) Q:'G S PSGPLTND=$G(^PS(53.5,G,0)) K:PSGPLTND="" ^PS(53.5,"AF",G) I PSGPLTND]"" I $$LOCK^PSGPLUTL(G,"PSGPL") D D UNLOCK^PSGPLUTL(G,"PSGPL")
.S WSF=$P(PSGPLTND,"^",7),D0=$S($P(PSGPLTND,"^",3):$P($P(PSGPLTND,"^",3),"."),1:DT)
.I '$D(^PS(57.6,D0)) F L +^PS(57.6,0):1 I S ND=$G(^(0)) S:ND="" ND="UNIT DOSE PICK LIST STATS^57.6D" S $P(ND,"^",3)=D0,$P(ND,"^",4)=$P(ND,"^",4)+1,^(0)=ND,^(D0,0)=D0 L -^PS(57.6,0) Q
.S T="",PSGPLFF=1
.F S T=$O(^PS(53.5,"AC",G,T)) Q:T="" S (WH,W)="" F S (W,WD)=$O(^PS(53.5,"AC",G,T,W)) Q:W="" S R="" D:'WSF GD1 F S R=$O(^PS(53.5,"AC",G,T,W,R)) Q:R="" S P="" F S P=$O(^PS(53.5,"AC",G,T,W,R,P)) Q:P="" D
..S PN=$P(P,"^",2),(DD,PD)="",S="A" S:WSF WD=$P(^PS(53.5,G,1,PN,0),"^",3) D:WD'=WH&WSF GD1
..F S S=$O(^PS(53.5,"AC",G,T,W,R,P,S)) Q:("Z"[S)!(S="NO ORDERS") F S PD=$O(^PS(53.5,"AC",G,T,W,R,P,S,PD)) Q:PD="" S O=+$P($G(^PS(53.5,G,1,PN,1,$P(PD,"^",2),0)),"^"),D2=$P($G(^PS(55,PN,5,O,0)),"^",2) S:'D2 D2="999Z" D
...F S DD=$O(^PS(53.5,"AC",G,T,W,R,P,S,PD,DD)) Q:(DD="")!(DD="NO DISPENSE DRUG") S PLR=$G(^PS(53.5,G,1,PN,1,$P(PD,"^",2),1,$P(DD,"^",2),0)) Q:PLR="" D:'$P(PLR,"^",4) FILE
.I PSGPLFF S $P(^PS(53.5,G,0),"^",5)=2,^PS(53.5,"AO",+$P(PSGPLTND,"^",2),$P(PSGPLTND,"^",3),G)="" K ^PS(53.5,"AF",G)
;
I $D(^TMP("PSGNCF",$J,"B")) D ^PSGPLFM
;
DONE ;
K %,AM,C,COST,D0,D1,D2,D3,DO,ECUD,ND,O,PIN,PLR,PN,PS,PSGPLFF,PSGPLTND,Q,WD,WH,WSF,PSGX,PSGY,PSGZ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGPLF 4007 printed Apr 09, 2024@21:04:51 Page 2
PSGPLF ;BIR/CML3-FILES AWAY PICK LIST DATA (BACKGROUND JOB) ;29 SEP 97 / 12:40 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**84,130,168**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA# 2191.
+4 ; Reference to ^PSDRUG is supported by DBIA# 2192.
+5 ; Reference to ^ECXUD1 is supported by DBIA# 172.
+6 ; Reference to ^DIC(42 is supported by DBIA# 1377.
+7 ; Reference to ^DIC(42 is supported by DBIA# 10039.
+8 ;
FILE ; add data to cost file and order
+1 SET PSGX=$PIECE(PLR,"^",2)
SET PSGY=$PIECE(PLR,"^",3)
if PSGX?7N1"DI"
SET PSGX=0
SET PSGX=+PSGX
if PSGY=""
SET $PIECE(PLR,"^",3)=PSGX
SET PSGY=PSGX
+2 SET COST=""
SET (D3,DO)=$PIECE(PLR,"^")
IF $GET(D3)
if '$DATA(^PS(55,PN,5,O,1,D3,0))
QUIT
+3 IF D3=+D3
SET D3=$PIECE($GET(^PS(55,PN,5,O,1,D3,0)),"^")
IF D3=+D3
SET COST=$PIECE($GET(^PSDRUG(D3,660)),"^",6)
+4 IF '$TEST
SET D3="999Z"
+5 IF COST=""
SET PSGPLFF=0
if D3="999Z"
SET D3=PN_","_O_","_DO
if '$DATA(^TMP("PSGNCF",$JOB,"B",D3))
SET ^(D3)=""
QUIT
+6 SET PS=PSGY<0*2
if PS
SET PSGY=-PSGY
SET COST=COST*PSGY
if 'PSGY&'COST
GOTO OS
+7 FOR
LOCK +^PS(57.6,D0,1,D1,1,D2,1,D3,0):1
IF $TEST
QUIT
+8 IF $DATA(^PS(57.6,D0,1,D1,1,D2,1,D3,0))
SET ND=^(0)
SET PSGZ=1
+9 IF '$TEST
SET ND=D3
SET PSGZ=0
+10 SET $PIECE(ND,"^",2+PS)=$PIECE(ND,"^",2+PS)+PSGY
SET $PIECE(ND,"^",3+PS)=$PIECE(ND,"^",3+PS)+COST
SET ^PS(57.6,D0,1,D1,1,D2,1,D3,0)=ND
LOCK -^PS(57.6,D0,1,D1,1,D2,1,D3,0)
+11 if PSGZ
GOTO OS
+12 FOR
LOCK +^PS(57.6,D0,1,D1,1,D2,1,0):1
IF $TEST
SET ND=$GET(^PS(57.6,D0,1,D1,1,D2,1,0))
if ND=""
SET ND="^57.63P^"
SET $PIECE(ND,"^",3)=D3
SET $PIECE(ND,"^",4)=$PIECE(ND,"^",4)+1
SET ^(0)=ND
LOCK -^PS(57.6,D0,1,D1,1,D2,1,0)
QUIT
+13 IF '$DATA(^PS(57.6,D0,1,D1,1,D2,0))
FOR
LOCK +^PS(57.6,D0,1,D1,1,0):1
IF $TEST
SET ND=$GET(^PS(57.6,D0,1,D1,1,0))
if ND=""
SET ND="^57.62P"
SET $PIECE(ND,"^",3)=D2
SET $PIECE(ND,"^",4)=$PIECE(ND,"^",4)+1
SET ^(0)=ND
LOCK -^PS(57.6,D0,1,D1,1,0)
QUIT
+14 ;
OS ;
+1 IF PSGX!PSGY
FOR
LOCK +^PS(55,PN,5,O,1,DO,0):1
IF $TEST
SET PSGZ=$GET(^PS(55,PN,5,O,1,DO,0))
SET $PIECE(PSGZ,"^",5)=$PIECE(PSGZ,"^",5)+PSGX
SET $PIECE(PSGZ,"^",PS>0+6)=$PIECE(PSGZ,"^",PS>0+6)+PSGY
SET ^(0)=PSGZ
LOCK -^PS(55,PN,5,O,1,DO,0)
QUIT
+2 NEW PSGSTRT
SET PSGSTRT=$PIECE($GET(^PS(55,PN,5,O,2)),"^",2)
+3 IF PSGY
IF D0=+D0
IF D1=+D1
IF D2=+D2
IF D3=+D3
if PS
SET PSGY=-PSGY
SET COST=-COST
DO ENPLF^PSGAMSA(PN,O,D3,PSGY,COST,1,D1,D2,D0)
SET X="ECXUD1"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET ECUD=PN_"^"_D0_"^"_D3_"^"_PSGY_"^"_D1_"^"_D2_";200^"_COST_"^"_PSGSTRT_"^"_$GET(O)
DO ^ECXUD1
+4 SET $PIECE(PLR,"^",4)=1
SET ^PS(53.5,G,1,PN,1,$PIECE(PD,"^",2),1,$PIECE(DD,"^",2),0)=PLR
+5 QUIT
+6 ;
GD1 ; get next (second) level (ward) in 57.6
+1 SET WH=WD
SET D1=$ORDER(^DIC(42,"B",WD,0))
if 'D1
SET D1="999Z"
if $DATA(^PS(57.6,D0,1,D1))
QUIT
+2 FOR
LOCK +^PS(57.6,D0,1,0):1
IF $TEST
SET ND=$GET(^PS(57.6,D0,1,0))
if ND=""
SET ND="^57.61PA"
SET $PIECE(ND,"^",3)=D1
if '$DATA(^(D1))
SET $PIECE(ND,"^",4)=$PIECE(ND,"^",4)+1
SET ^(0)=ND
SET ^(D1,0)=D1
LOCK -^PS(57.6,D0,1,0)
QUIT
+3 QUIT
+4 ;
EN ; action starts here
+1 NEW G,T,W,R,P,S,PD,DD,DDRG
DO NOW^%DTC
SET PSGDT=%
SET G=0
KILL C,^TMP("PSGNCF",$JOB)
+2 FOR
SET G=$ORDER(^PS(53.5,"AF",G))
if 'G
QUIT
SET PSGPLTND=$GET(^PS(53.5,G,0))
if PSGPLTND=""
KILL ^PS(53.5,"AF",G)
IF PSGPLTND]""
IF $$LOCK^PSGPLUTL(G,"PSGPL")
Begin DoDot:1
+3 SET WSF=$PIECE(PSGPLTND,"^",7)
SET D0=$SELECT($PIECE(PSGPLTND,"^",3):$PIECE($PIECE(PSGPLTND,"^",3),"."),1:DT)
+4 IF '$DATA(^PS(57.6,D0))
FOR
LOCK +^PS(57.6,0):1
IF $TEST
SET ND=$GET(^(0))
if ND=""
SET ND="UNIT DOSE PICK LIST STATS^57.6D"
SET $PIECE(ND,"^",3)=D0
SET $PIECE(ND,"^",4)=$PIECE(ND,"^",4)+1
SET ^(0)=ND
SET ^(D0,0)=D0
LOCK -^PS(57.6,0)
QUIT
+5 SET T=""
SET PSGPLFF=1
+6 FOR
SET T=$ORDER(^PS(53.5,"AC",G,T))
if T=""
QUIT
SET (WH,W)=""
FOR
SET (W,WD)=$ORDER(^PS(53.5,"AC",G,T,W))
if W=""
QUIT
SET R=""
if 'WSF
DO GD1
FOR
SET R=$ORDER(^PS(53.5,"AC",G,T,W,R))
if R=""
QUIT
SET P=""
FOR
SET P=$ORDER(^PS(53.5,"AC",G,T,W,R,P))
if P=""
QUIT
Begin DoDot:2
+7 SET PN=$PIECE(P,"^",2)
SET (DD,PD)=""
SET S="A"
if WSF
SET WD=$PIECE(^PS(53.5,G,1,PN,0),"^",3)
if WD'=WH&WSF
DO GD1
+8 FOR
SET S=$ORDER(^PS(53.5,"AC",G,T,W,R,P,S))
if ("Z"[S)!(S="NO ORDERS")
QUIT
FOR
SET PD=$ORDER(^PS(53.5,"AC",G,T,W,R,P,S,PD))
if PD=""
QUIT
SET O=+$PIECE($GET(^PS(53.5,G,1,PN,1,$PIECE(PD,"^",2),0)),"^")
SET D2=$PIECE($GET(^PS(55,PN,5,O,0)),"^",2)
if 'D2
SET D2="999Z"
Begin DoDot:3
+9 FOR
SET DD=$ORDER(^PS(53.5,"AC",G,T,W,R,P,S,PD,DD))
if (DD="")!(DD="NO DISPENSE DRUG")
QUIT
SET PLR=$GET(^PS(53.5,G,1,PN,1,$PIECE(PD,"^",2),1,$PIECE(DD,"^",2),0))
if PLR=""
QUIT
if '$PIECE(PLR,"^",4)
DO FILE
End DoDot:3
End DoDot:2
+10 IF PSGPLFF
SET $PIECE(^PS(53.5,G,0),"^",5)=2
SET ^PS(53.5,"AO",+$PIECE(PSGPLTND,"^",2),$PIECE(PSGPLTND,"^",3),G)=""
KILL ^PS(53.5,"AF",G)
End DoDot:1
DO UNLOCK^PSGPLUTL(G,"PSGPL")
+11 ;
+12 IF $DATA(^TMP("PSGNCF",$JOB,"B"))
DO ^PSGPLFM
+13 ;
DONE ;
+1 KILL %,AM,C,COST,D0,D1,D2,D3,DO,ECUD,ND,O,PIN,PLR,PN,PS,PSGPLFF,PSGPLTND,Q,WD,WH,WSF,PSGX,PSGY,PSGZ
QUIT
