PSGPL1 ;BIR/CML3-GATHER PICK LIST DATA ;26 JAN 99 / 9:30 AM
;;5.0; INPATIENT MEDICATIONS ;**25,50**;16 DEC 97
;
; Reference to ^PSI(58.1 is supported by DBIA# 2284.
; Reference to ^PS(55 is supported by DBIA# 2191.
; Reference to ^PSD(58.8 is supported by DBIA# 2283.
; Reference to ^DIC(42 is supported by DBIA# 10039.
;
EN ; entry point for PSGPL - get ward info, loop thru patients
N PRINT S PRINT=0
I $G(RERUN)=2,$D(OG) D
.F I $$LOCK^PSGPLUTL(OG,"PSGPL") Q
.K DA,DIK S DIK="^PS(53.5,",DA=OG D ^DIK K DIK I $D(^PS(57.5,PSGPLWG,2)),+^(2)=OG S ^(2)=$P(^(2),"^",6,20)
F I $$LOCK^PSGPLUTL(PSGPLG,"PSGPL") Q
S PSGPLTND=$G(^PS(53.5,PSGPLG,0)) G:PSGPLTND="" DONE S WSF=$P(PSGPLTND,"^",7),EST=$S($P(PSGPLTND,"^",13):"A",1:"Z")
D NOW^%DTC S PSGDT=%,X1=$P(PSGPLS,"."),X2=-1 D C^%DTC S PSGPLD=X_(PSGPLS#1)
F PSGPLWD=0:0 S PSGPLWD=$O(^PS(57.5,"AC",PSGPLWG,PSGPLWD)) Q:'PSGPLWD S WDN=$P($G(^DIC(42,PSGPLWD,0)),"^") I WDN]"" D
.S PSGPLWDN=$S('WSF:WDN,1:"zns") F PSGP=0:0 S PSGP=$O(^DPT("CN",WDN,PSGP)) Q:'PSGP S PSJACNWP=1 D ^PSJAC,ENUNM^PSGOU D
..S TM="zz",RB=PSJPRB S:RB="" RB="zz" I RB'="zz" S X=+$O(^PS(57.7,"AWRT",PSGPLWD,RB,0)) I X,$D(^PS(57.7,PSGPLWD,1,X,0)),$P(^(0),"^")]"" S TM=$P(^(0),"^")
..S PSJJORD=0 D PATIENT Q:'$O(^PS(55,PSGP,5,"AUS",PSGPLS))
..F PST="C","O","OC","P","R" F SD=PSGPLD:0 S SD=$O(^PS(55,PSGP,5,"AU",PST,SD)) Q:'SD F PSJJORD=0:0 S PSJJORD=$O(^PS(55,PSGP,5,"AU",PST,SD,PSJJORD)) Q:'PSJJORD D ENASET
;
I $D(^PS(53.5,PSGPLG)) S DIK="^PS(53.5,",DA=PSGPLG D
.F DIK(1)=.01,.02,.05 D EN1^DIK
.K DIK D NOW^%DTC S $P(^PS(53.5,PSGPLG,0),"^",9)=% S:IO]"" PRINT=1
;
DONE ;
D UNLOCK^PSGPLUTL(PSGPLG,"PSGPL")
D:PRINT ^PSGPLR
D ^%ZISC,ENKV^PSGSETU K DRG,PSGP,PSGORD,PN,PSGPLC,PSGPLD,PSGPLO,PSGPLTND,PSGPLWD,PSGPLWDN,PSGMAR,PSJACNWP,PSJJORD,PSGLOCK,P,ST,SD,TM,WSF,DDC Q
;
ENASET ; this tag can be called from above or from update (^PSGPLUP0)
; if order not being edited (OE), on hold (HD), non-verified (NV) or self-med (SM) get units (^PSGPL0)
S PSGPLDC="",PSGLOCK="",NST=$S(SD<PSGPLS:EST,1:PST)
L +^PS(55,PSGP,5,PSJJORD):1 I K ^PS(55,"AUE",PSGP,PSJJORD) S PSGLOCK=1
G:NST=EST A1
S PSGPLDC=$S('PSGLOCK:"OE",$P($G(^PS(55,PSGP,5,PSJJORD,0)),"^",9)="H":"HD",$P($G(^(0)),"^",5):"SM",'$P($G(^PS(55,PSGP,5,PSJJORD,4)),"^",9):"NV",1:"")
;
A1 ; if there are orders, set the order and drug multiples.
; PSJJORD = unit dose subfile order ien
; PSGORD = PL order multiple ien
; DRG = unit dose subfile dispense drug multiple ien
; PSGDRG = PL dispense drug multiple ien
I '$D(^PS(53.5,PSGPLG,1,PSGP,1)) S ^(1,0)="^53.52A^0^0"
S PSGORD=(+$P(^PS(53.5,PSGPLG,1,PSGP,1,0),"^",3)+1),$P(^(0),"^",3,4)=PSGORD_"^"_(+$P(^(0),"^",4)+1)
S ^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,0)=PSJJORD_"^"_NST_"^"_"^"_PSGPLDC,$P(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,0),U,6)=$P($G(^PS(55,PSGP,5,PSJJORD,.2)),"^"),^PS(53.5,PSGPLG,1,PSGP,1,"B",PSJJORD,PSGORD)=""
I $D(^PS(55,PSGP,5,PSJJORD,1))=10 S DDC=0 F DRG=0:0 S DRG=$O(^PS(55,PSGP,5,PSJJORD,1,DRG)) Q:'DRG S DND=$G(^(DRG,0)) I DND D
.S:PSGPLDC]"" PSGPLC=PSGPLDC I PSGPLDC="" S PSGPLO=PSJJORD D ^PSGPL0
.I '$D(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1)) S ^(1,0)="^53.53A^0^0"
.S PSGDRG=(+$P(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,0),"^",3)+1),$P(^(0),"^",3,4)=PSGDRG_"^"_(+$P(^(0),"^",4)+1)
.I PSGPLDC'?1.A S PSGPLC=$$WS^PSGPL1(+DND,+PSGPLWD,PSGPLC,PSGDT)
.I $S($P(DND,"^",3):$P(DND,"^",3)\1'>PSGPLF,1:NST=EST) S ^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,PSGDRG,0)=DRG_"^"_$S(NST=EST:"",1:$P(DND,"^",3)\1_"DI"),^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,"B",DRG,PSGDRG)="",DDC=DDC+1 Q
.S ^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,PSGDRG,0)=DRG_"^"_$S(PSGPLC&$P(DND,"^",2):PSGPLC*$S($P($P(DND,"^",2),".",2)]"":$P($P(DND,"^",2),".")+1,1:$P(DND,"^",2)),1:PSGPLC),^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,"B",DRG,PSGDRG)="",DDC=DDC+1
I PSGLOCK L -^PS(55,PSGP,5,PSJJORD)
K PSGDRG Q
PATIENT ; add a patient to Pick List. Can also be called from ^PSGPLUP0.
I '$D(^PS(53.5,PSGPLG,1)) S ^(1,0)="^53.51PA^0^0"
S $P(^(0),"^",3,4)=PSGP_"^"_($P(^PS(53.5,PSGPLG,1,0),"^",4)+1)
;The naked indicator on the line above references the global reference to the right of the equal sign.
S ^PS(53.5,PSGPLG,1,PSGP,0)=PSGP_"^"_TM_"^"_WDN_"^"_RB,^PS(53.5,PSGPLG,1,"B",PSGP,PSGP)=""
I $G(PSGAU)=1 S DR=".05////1",DIE="^PS(53.5,"_PSGPLG_",1,",DA(1)=PSGPLG,DA=PSGP D ^DIE K DIE
Q
WS(DND,WD,PSGPLC,PSGDT) ;
N AOU,DRUG
F F="^PSD(58.8,","^PSI(58.1," I $D(@(F_"""D"","_DND_","_WD_")")) D
.F AOU=0:0 S AOU=$O(@(F_"""D"","_DND_","_WD_","_AOU_")")) Q:'AOU!(PSGPLC="WS") D
..S DRUG=$O(@(F_AOU_",1,""B"","_DND_",0)")) Q:'DRUG S X=$P($G(^(DRUG,0)),U,3) I 'X!(X>PSGDT) S PSGPLC="WS"
Q PSGPLC
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGPL1 4682 printed Sep 23, 2025@19:38:51 Page 2
PSGPL1 ;BIR/CML3-GATHER PICK LIST DATA ;26 JAN 99 / 9:30 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**25,50**;16 DEC 97
+2 ;
+3 ; Reference to ^PSI(58.1 is supported by DBIA# 2284.
+4 ; Reference to ^PS(55 is supported by DBIA# 2191.
+5 ; Reference to ^PSD(58.8 is supported by DBIA# 2283.
+6 ; Reference to ^DIC(42 is supported by DBIA# 10039.
+7 ;
EN ; entry point for PSGPL - get ward info, loop thru patients
+1 NEW PRINT
SET PRINT=0
+2 IF $GET(RERUN)=2
IF $DATA(OG)
Begin DoDot:1
+3 FOR
IF $$LOCK^PSGPLUTL(OG,"PSGPL")
QUIT
+4 KILL DA,DIK
SET DIK="^PS(53.5,"
SET DA=OG
DO ^DIK
KILL DIK
IF $DATA(^PS(57.5,PSGPLWG,2))
IF +^(2)=OG
SET ^(2)=$PIECE(^(2),"^",6,20)
End DoDot:1
+5 FOR
IF $$LOCK^PSGPLUTL(PSGPLG,"PSGPL")
QUIT
+6 SET PSGPLTND=$GET(^PS(53.5,PSGPLG,0))
if PSGPLTND=""
GOTO DONE
SET WSF=$PIECE(PSGPLTND,"^",7)
SET EST=$SELECT($PIECE(PSGPLTND,"^",13):"A",1:"Z")
+7 DO NOW^%DTC
SET PSGDT=%
SET X1=$PIECE(PSGPLS,".")
SET X2=-1
DO C^%DTC
SET PSGPLD=X_(PSGPLS#1)
+8 FOR PSGPLWD=0:0
SET PSGPLWD=$ORDER(^PS(57.5,"AC",PSGPLWG,PSGPLWD))
if 'PSGPLWD
QUIT
SET WDN=$PIECE($GET(^DIC(42,PSGPLWD,0)),"^")
IF WDN]""
Begin DoDot:1
+9 SET PSGPLWDN=$SELECT('WSF:WDN,1:"zns")
FOR PSGP=0:0
SET PSGP=$ORDER(^DPT("CN",WDN,PSGP))
if 'PSGP
QUIT
SET PSJACNWP=1
DO ^PSJAC
DO ENUNM^PSGOU
Begin DoDot:2
+10 SET TM="zz"
SET RB=PSJPRB
if RB=""
SET RB="zz"
IF RB'="zz"
SET X=+$ORDER(^PS(57.7,"AWRT",PSGPLWD,RB,0))
IF X
IF $DATA(^PS(57.7,PSGPLWD,1,X,0))
IF $PIECE(^(0),"^")]""
SET TM=$PIECE(^(0),"^")
+11 SET PSJJORD=0
DO PATIENT
if '$ORDER(^PS(55,PSGP,5,"AUS",PSGPLS))
QUIT
+12 FOR PST="C","O","OC","P","R"
FOR SD=PSGPLD:0
SET SD=$ORDER(^PS(55,PSGP,5,"AU",PST,SD))
if 'SD
QUIT
FOR PSJJORD=0:0
SET PSJJORD=$ORDER(^PS(55,PSGP,5,"AU",PST,SD,PSJJORD))
if 'PSJJORD
QUIT
DO ENASET
End DoDot:2
End DoDot:1
+13 ;
+14 IF $DATA(^PS(53.5,PSGPLG))
SET DIK="^PS(53.5,"
SET DA=PSGPLG
Begin DoDot:1
+15 FOR DIK(1)=.01,.02,.05
DO EN1^DIK
+16 KILL DIK
DO NOW^%DTC
SET $PIECE(^PS(53.5,PSGPLG,0),"^",9)=%
if IO]""
SET PRINT=1
End DoDot:1
+17 ;
DONE ;
+1 DO UNLOCK^PSGPLUTL(PSGPLG,"PSGPL")
+2 if PRINT
DO ^PSGPLR
+3 DO ^%ZISC
DO ENKV^PSGSETU
KILL DRG,PSGP,PSGORD,PN,PSGPLC,PSGPLD,PSGPLO,PSGPLTND,PSGPLWD,PSGPLWDN,PSGMAR,PSJACNWP,PSJJORD,PSGLOCK,P,ST,SD,TM,WSF,DDC
QUIT
+4 ;
ENASET ; this tag can be called from above or from update (^PSGPLUP0)
+1 ; if order not being edited (OE), on hold (HD), non-verified (NV) or self-med (SM) get units (^PSGPL0)
+2 SET PSGPLDC=""
SET PSGLOCK=""
SET NST=$SELECT(SD<PSGPLS:EST,1:PST)
+3 LOCK +^PS(55,PSGP,5,PSJJORD):1
IF $TEST
KILL ^PS(55,"AUE",PSGP,PSJJORD)
SET PSGLOCK=1
+4 if NST=EST
GOTO A1
+5 SET PSGPLDC=$SELECT('PSGLOCK:"OE",$PIECE($GET(^PS(55,PSGP,5,PSJJORD,0)),"^",9)="H":"HD",$PIECE($GET(^(0)),"^",5):"SM",'$PIECE($GET(^PS(55,PSGP,5,PSJJORD,4)),"^",9):"NV",1:"")
+6 ;
A1 ; if there are orders, set the order and drug multiples.
+1 ; PSJJORD = unit dose subfile order ien
+2 ; PSGORD = PL order multiple ien
+3 ; DRG = unit dose subfile dispense drug multiple ien
+4 ; PSGDRG = PL dispense drug multiple ien
+5 IF '$DATA(^PS(53.5,PSGPLG,1,PSGP,1))
SET ^(1,0)="^53.52A^0^0"
+6 SET PSGORD=(+$PIECE(^PS(53.5,PSGPLG,1,PSGP,1,0),"^",3)+1)
SET $PIECE(^(0),"^",3,4)=PSGORD_"^"_(+$PIECE(^(0),"^",4)+1)
+7 SET ^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,0)=PSJJORD_"^"_NST_"^"_"^"_PSGPLDC
SET $PIECE(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,0),U,6)=$PIECE($GET(^PS(55,PSGP,5,PSJJORD,.2)),"^")
SET ^PS(53.5,PSGPLG,1,PSGP,1,"B",PSJJORD,PSGORD)=""
+8 IF $DATA(^PS(55,PSGP,5,PSJJORD,1))=10
SET DDC=0
FOR DRG=0:0
SET DRG=$ORDER(^PS(55,PSGP,5,PSJJORD,1,DRG))
if 'DRG
QUIT
SET DND=$GET(^(DRG,0))
IF DND
Begin DoDot:1
+9 if PSGPLDC]""
SET PSGPLC=PSGPLDC
IF PSGPLDC=""
SET PSGPLO=PSJJORD
DO ^PSGPL0
+10 IF '$DATA(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1))
SET ^(1,0)="^53.53A^0^0"
+11 SET PSGDRG=(+$PIECE(^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,0),"^",3)+1)
SET $PIECE(^(0),"^",3,4)=PSGDRG_"^"_(+$PIECE(^(0),"^",4)+1)
+12 IF PSGPLDC'?1.A
SET PSGPLC=$$WS^PSGPL1(+DND,+PSGPLWD,PSGPLC,PSGDT)
+13 IF $SELECT($PIECE(DND,"^",3):$PIECE(DND,"^",3)\1'>PSGPLF,1:NST=EST)
SET ^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,PSGDRG,0)=DRG_"^"_$SELECT(NST=EST:"",1:$PIECE(DND,"^",3)\1_"DI")
SET ^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,"B",DRG,PSGDRG)=""
SET DDC=DDC+1
QUIT
+14 SET ^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,PSGDRG,0)=DRG_"^"_$SELECT(PSGPLC&$PIECE(DND,"^",2):PSGPLC*$SELECT($PIECE($PIECE(DND,"^",2),".",2)]"":$PIECE($PIECE(DND,"^",2),".")+1,1:$PIECE(DND,"^",2)),1:PSGPLC)
SET ^PS(53.5,PSGPLG,1,PSGP,1,PSGORD,1,"B",DRG,PSGDRG)=""
SET DDC=DDC+1
End DoDot:1
+15 IF PSGLOCK
LOCK -^PS(55,PSGP,5,PSJJORD)
+16 KILL PSGDRG
QUIT
PATIENT ; add a patient to Pick List. Can also be called from ^PSGPLUP0.
+1 IF '$DATA(^PS(53.5,PSGPLG,1))
SET ^(1,0)="^53.51PA^0^0"
+2 SET $PIECE(^(0),"^",3,4)=PSGP_"^"_($PIECE(^PS(53.5,PSGPLG,1,0),"^",4)+1)
+3 ;The naked indicator on the line above references the global reference to the right of the equal sign.
+4 SET ^PS(53.5,PSGPLG,1,PSGP,0)=PSGP_"^"_TM_"^"_WDN_"^"_RB
SET ^PS(53.5,PSGPLG,1,"B",PSGP,PSGP)=""
+5 IF $GET(PSGAU)=1
SET DR=".05////1"
SET DIE="^PS(53.5,"_PSGPLG_",1,"
SET DA(1)=PSGPLG
SET DA=PSGP
DO ^DIE
KILL DIE
+6 QUIT
WS(DND,WD,PSGPLC,PSGDT) ;
+1 NEW AOU,DRUG
+2 FOR F="^PSD(58.8,","^PSI(58.1,"
IF $DATA(@(F_"""D"","_DND_","_WD_")"))
Begin DoDot:1
+3 FOR AOU=0:0
SET AOU=$ORDER(@(F_"""D"","_DND_","_WD_","_AOU_")"))
if 'AOU!(PSGPLC="WS")
QUIT
Begin DoDot:2
+4 SET DRUG=$ORDER(@(F_AOU_",1,""B"","_DND_",0)"))
if 'DRUG
QUIT
SET X=$PIECE($GET(^(DRUG,0)),U,3)
IF 'X!(X>PSGDT)
SET PSGPLC="WS"
End DoDot:2
End DoDot:1
+5 QUIT PSGPLC
