PSGPL ;BIR/CML3-PICK LIST ;12 DEC 97 / 10:01 AM
;;5.0; INPATIENT MEDICATIONS ;**50,184**;16 DEC 97;Build 12
;
; Reference to ^PS(59.7 is supported by DBIA #2181.
;
BEGIN ; get ward group, last pick list # for group, see if it's a rerun.
; ND2 - 2 node of WARD GROUP file or WARD GROUP^^start date^stop date from pick list ) node
; PSGPLG - pick list number PSGPLWG - ward group number
; PSGPLF - start date PSGPLWGP - 5 node from WARD GROUP
;
D ENCV^PSGSETU,NOW^%DTC S PSGDT=%,RERUN=0
N PSJSITE,PSJPRN S PSJSITE=0,PSJSITE=$O(^PS(59.7,PSJSITE)) I $P($G(^(PSJSITE,26)),U,5)=1 S PSJPRN=1
S DIC("S")="I $P(^(0),""^"",2)=""P""",DIC(0)="QEAMI",DIC="^PS(57.5," W ! D ^DIC K DIC G:Y'>0 DONE S PSGPLWG=+Y,ND2=$G(^PS(57.5,+Y,2)),PSGPLWGP=$G(^(5)),PSGPLG=+ND2
I 'ND2,$D(^PS(53.5,"A",PSGPLWG)) F Q=0:0 S Q=$O(^PS(53.5,"A",PSGPLWG,Q)) Q:'Q I '$O(^(Q)),$D(^PS(53.5,Q,0)) S ND2=$P(^(0),"^",2)_"^^"_$P(^(0),"^",3,4),PSGPLG=Q Q
I PSGDT<$P(ND2,"^",3) D RERUN G UL:%<0,BEGIN:%=2
I ND2]"" D DTEXST S PSGOD=$$ENDTC^PSGMI(PSGPLS) W !,"Start date/time for this pick list: ",PSGOD S MES="STOP" D GETSF G:Y<0 DONE S PSGPLF=Y G BOTH
F MES="START","STOP" D GETSF G:Y<0 DONE
;
BOTH ;
W ! F L +^PS(53.5,0):1 I S ND=$G(^PS(53.5,0)) S:ND="" ND="PICK LIST^53.5" Q
F PSGPLG=$P(ND,"^",3)+1:1 I '$D(^PS(53.5,PSGPLG)) I $$LOCK^PSGPLUTL(PSGPLG,"PSGPL") S $P(ND,"^",3)=PSGPLG,$P(ND,"^",4)=$P(ND,"^",4)+1,^PS(53.5,0)=ND Q
L -^PS(53.5,0)
D ENPL^PSGTI I $D(IO("Q")) G:'$D(ZTSK) UL W !!,"Pick list queued!" D SET G UL
I POP W !!,"No device chosen for Pick List ",$E("re",1,RERUN),"run." G UL
W !,"...this may take a while...(you really should QUEUE the pick list)..." D SET,EN^PSGPL1
;
UL ;
D UNLOCK^PSGPLUTL(PSGPLG,"PSGPL")
;
DONE ;
D ^%ZISC,ENKV^PSGSETU K AM,DIC,FD,FFF,MES,ND,ND2,OG,OS,POP,PSGION,PSGID,PSGOD,PSGPLF,PSGPLG,PSGPLS,PSGPLWG,PSGPLWGP,Q,RERUN,ST,XX,ZTOUT,PSGDT,EST Q
;
SET ;
I RERUN 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)
S ^PS(53.5,PSGPLG,0)=PSGPLG_"^"_PSGPLWG_"^"_PSGPLS_"^"_PSGPLF_"^^"_$P(PSGPLWGP,"^",1,3)_"^^^"_PSGDT_"^^"_$P(PSGPLWGP,"^",7),^PS(57.5,PSGPLWG,2)=PSGPLG_"^"_PSGDT_"^"_PSGPLS_"^"_PSGPLF_"^"_DUZ_"^"_$P(ND2,"^",1,15),^PS(53.5,"A",PSGPLWG,PSGPLG)=""
S DIK="^PS(53.5,",DA=PSGPLG D IX^DIK K DIK Q
;
DTEXST ;
S PSGPLS=$$EN^PSGCT($P(ND2,"^",4),1),X=$$ENDTC^PSGMI($P(ND2,"^",4)),Y=$$ENDTC^PSGMI($P(ND2,"^",3)),XX=$$ENDTC^PSGMI($P(ND2,"^",2))
W !!,"The PICK LIST for this WARD GROUP was last run",$S(XX:" on "_XX,1:""),!," for ",Y," through ",X,!
I $D(^PS(53.5,PSGPLG,0)),$P(^(0),"^",11),'$P(^(0),"^",9) W $C(7),$C(7),!,"*** THIS PICK LIST HAS NOT RUN TO COMPLETION. ***",!
Q
;
GETSF ;
K %DT S %DT="AERTX",%DT("A")="Enter "_MES_" date/time for this pick list: "
I MES["O",$D(^PS(57.5,PSGPLWG,0)),$P(^(0),"^",3) S X=$$EN^PSGCT(PSGPLS,$P(^(0),"^",3)*60-1),Y=$$ENDD^PSGMI(X),%DT("B")=Y
GETSF1 D ^%DT I Y<0 W $C(7),!!,"This PICK LIST cannot be ",$E("re",1,RERUN),"run without a ",MES," date." Q
S @($S(MES["O":"PSGPLF",1:"PSGPLS"))=Y
I MES["O",(Y'>PSGPLS) W $C(7),!!,"*** Stop date must be greater than start date !! ***",! G GETSF1
;PSJ*5*184;Add warning message and prompt if stop date greater than 7 days in the future.
N X,PSGPLSF S X1=PSGPLS,X2="7" D C^%DTC S PSGPLSF=X
I MES["O",(Y>PSGPLSF) D I %'=1 G GETSF1
. W $C(7),!!,"*** WARNING: You're Attempting to run the Pick List for greater than 7 days ***",!
. W !,"Are you Sure (Y/N):" S %=2 D YN^DICN
. Q
Q
;
RERUN ;
I '$$LOCK^PSGPLUTL(PSGPLG,"PSGPL") W $C(7),!!,"** THE NEXT PICK LIST FOR THIS WARD GROUP IS CURRENTLY RUNNING. **" S %=2 Q
D DTEXST F W !,"Do you want to rerun this pick list" S %=0 D YN^DICN Q:% D:%Y]"" DTQ W:%Y="" $C(7)," (Answer required.)"
I %=1 S OG=PSGPLG,OS=$P(^PS(53.5,OG,0),"^",3),RERUN=2 S:+ND2=OG ND2=$P(ND2,"^",6,20) D UNLOCK^PSGPLUTL(PSGPLG,"PSGPL") Q
D UNLOCK^PSGPLUTL(PSGPLG,"PSGPL") Q
;
DTQ ;
W !!?2,"Enter a 'Y' to rerun this pick list. Enter an 'N' (or '^') to NOT rerun this pick list. NOTE: Rerunning a pick list deletes all of its old data.",! Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGPL 4133 printed Sep 23, 2025@19:38:50 Page 2
PSGPL ;BIR/CML3-PICK LIST ;12 DEC 97 / 10:01 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**50,184**;16 DEC 97;Build 12
+2 ;
+3 ; Reference to ^PS(59.7 is supported by DBIA #2181.
+4 ;
BEGIN ; get ward group, last pick list # for group, see if it's a rerun.
+1 ; ND2 - 2 node of WARD GROUP file or WARD GROUP^^start date^stop date from pick list ) node
+2 ; PSGPLG - pick list number PSGPLWG - ward group number
+3 ; PSGPLF - start date PSGPLWGP - 5 node from WARD GROUP
+4 ;
+5 DO ENCV^PSGSETU
DO NOW^%DTC
SET PSGDT=%
SET RERUN=0
+6 NEW PSJSITE,PSJPRN
SET PSJSITE=0
SET PSJSITE=$ORDER(^PS(59.7,PSJSITE))
IF $PIECE($GET(^(PSJSITE,26)),U,5)=1
SET PSJPRN=1
+7 SET DIC("S")="I $P(^(0),""^"",2)=""P"""
SET DIC(0)="QEAMI"
SET DIC="^PS(57.5,"
WRITE !
DO ^DIC
KILL DIC
if Y'>0
GOTO DONE
SET PSGPLWG=+Y
SET ND2=$GET(^PS(57.5,+Y,2))
SET PSGPLWGP=$GET(^(5))
SET PSGPLG=+ND2
+8 IF 'ND2
IF $DATA(^PS(53.5,"A",PSGPLWG))
FOR Q=0:0
SET Q=$ORDER(^PS(53.5,"A",PSGPLWG,Q))
if 'Q
QUIT
IF '$ORDER(^(Q))
IF $DATA(^PS(53.5,Q,0))
SET ND2=$PIECE(^(0),"^",2)_"^^"_$PIECE(^(0),"^",3,4)
SET PSGPLG=Q
QUIT
+9 IF PSGDT<$PIECE(ND2,"^",3)
DO RERUN
if %<0
GOTO UL
if %=2
GOTO BEGIN
+10 IF ND2]""
DO DTEXST
SET PSGOD=$$ENDTC^PSGMI(PSGPLS)
WRITE !,"Start date/time for this pick list: ",PSGOD
SET MES="STOP"
DO GETSF
if Y<0
GOTO DONE
SET PSGPLF=Y
GOTO BOTH
+11 FOR MES="START","STOP"
DO GETSF
if Y<0
GOTO DONE
+12 ;
BOTH ;
+1 WRITE !
FOR
LOCK +^PS(53.5,0):1
IF $TEST
SET ND=$GET(^PS(53.5,0))
if ND=""
SET ND="PICK LIST^53.5"
QUIT
+2 FOR PSGPLG=$PIECE(ND,"^",3)+1:1
IF '$DATA(^PS(53.5,PSGPLG))
IF $$LOCK^PSGPLUTL(PSGPLG,"PSGPL")
SET $PIECE(ND,"^",3)=PSGPLG
SET $PIECE(ND,"^",4)=$PIECE(ND,"^",4)+1
SET ^PS(53.5,0)=ND
QUIT
+3 LOCK -^PS(53.5,0)
+4 DO ENPL^PSGTI
IF $DATA(IO("Q"))
if '$DATA(ZTSK)
GOTO UL
WRITE !!,"Pick list queued!"
DO SET
GOTO UL
+5 IF POP
WRITE !!,"No device chosen for Pick List ",$EXTRACT("re",1,RERUN),"run."
GOTO UL
+6 WRITE !,"...this may take a while...(you really should QUEUE the pick list)..."
DO SET
DO EN^PSGPL1
+7 ;
UL ;
+1 DO UNLOCK^PSGPLUTL(PSGPLG,"PSGPL")
+2 ;
DONE ;
+1 DO ^%ZISC
DO ENKV^PSGSETU
KILL AM,DIC,FD,FFF,MES,ND,ND2,OG,OS,POP,PSGION,PSGID,PSGOD,PSGPLF,PSGPLG,PSGPLS,PSGPLWG,PSGPLWGP,Q,RERUN,ST,XX,ZTOUT,PSGDT,EST
QUIT
+2 ;
SET ;
+1 IF RERUN
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)
+2 SET ^PS(53.5,PSGPLG,0)=PSGPLG_"^"_PSGPLWG_"^"_PSGPLS_"^"_PSGPLF_"^^"_$PIECE(PSGPLWGP,"^",1,3)_"^^^"_PSGDT_"^^"_$PIECE(PSGPLWGP,"^",7)
SET ^PS(57.5,PSGPLWG,2)=PSGPLG_"^"_PSGDT_"^"_PSGPLS_"^"_PSGPLF_"^"_DUZ_"^"_$PIECE(ND2,"^",1,15)
SET ^PS(53.5,"A",PSGPLWG,PSGPLG)=""
+3 SET DIK="^PS(53.5,"
SET DA=PSGPLG
DO IX^DIK
KILL DIK
QUIT
+4 ;
DTEXST ;
+1 SET PSGPLS=$$EN^PSGCT($PIECE(ND2,"^",4),1)
SET X=$$ENDTC^PSGMI($PIECE(ND2,"^",4))
SET Y=$$ENDTC^PSGMI($PIECE(ND2,"^",3))
SET XX=$$ENDTC^PSGMI($PIECE(ND2,"^",2))
+2 WRITE !!,"The PICK LIST for this WARD GROUP was last run",$SELECT(XX:" on "_XX,1:""),!," for ",Y," through ",X,!
+3 IF $DATA(^PS(53.5,PSGPLG,0))
IF $PIECE(^(0),"^",11)
IF '$PIECE(^(0),"^",9)
WRITE $CHAR(7),$CHAR(7),!,"*** THIS PICK LIST HAS NOT RUN TO COMPLETION. ***",!
+4 QUIT
+5 ;
GETSF ;
+1 KILL %DT
SET %DT="AERTX"
SET %DT("A")="Enter "_MES_" date/time for this pick list: "
+2 IF MES["O"
IF $DATA(^PS(57.5,PSGPLWG,0))
IF $PIECE(^(0),"^",3)
SET X=$$EN^PSGCT(PSGPLS,$PIECE(^(0),"^",3)*60-1)
SET Y=$$ENDD^PSGMI(X)
SET %DT("B")=Y
GETSF1 DO ^%DT
IF Y<0
WRITE $CHAR(7),!!,"This PICK LIST cannot be ",$EXTRACT("re",1,RERUN),"run without a ",MES," date."
QUIT
+1 SET @($SELECT(MES["O":"PSGPLF",1:"PSGPLS"))=Y
+2 IF MES["O"
IF (Y'>PSGPLS)
WRITE $CHAR(7),!!,"*** Stop date must be greater than start date !! ***",!
GOTO GETSF1
+3 ;PSJ*5*184;Add warning message and prompt if stop date greater than 7 days in the future.
+4 NEW X,PSGPLSF
SET X1=PSGPLS
SET X2="7"
DO C^%DTC
SET PSGPLSF=X
+5 IF MES["O"
IF (Y>PSGPLSF)
Begin DoDot:1
+6 WRITE $CHAR(7),!!,"*** WARNING: You're Attempting to run the Pick List for greater than 7 days ***",!
+7 WRITE !,"Are you Sure (Y/N):"
SET %=2
DO YN^DICN
+8 QUIT
End DoDot:1
IF %'=1
GOTO GETSF1
+9 QUIT
+10 ;
RERUN ;
+1 IF '$$LOCK^PSGPLUTL(PSGPLG,"PSGPL")
WRITE $CHAR(7),!!,"** THE NEXT PICK LIST FOR THIS WARD GROUP IS CURRENTLY RUNNING. **"
SET %=2
QUIT
+2 DO DTEXST
FOR
WRITE !,"Do you want to rerun this pick list"
SET %=0
DO YN^DICN
if %
QUIT
if %Y]""
DO DTQ
if %Y=""
WRITE $CHAR(7)," (Answer required.)"
+3 IF %=1
SET OG=PSGPLG
SET OS=$PIECE(^PS(53.5,OG,0),"^",3)
SET RERUN=2
if +ND2=OG
SET ND2=$PIECE(ND2,"^",6,20)
DO UNLOCK^PSGPLUTL(PSGPLG,"PSGPL")
QUIT
+4 DO UNLOCK^PSGPLUTL(PSGPLG,"PSGPL")
QUIT
+5 ;
DTQ ;
+1 WRITE !!?2,"Enter a 'Y' to rerun this pick list. Enter an 'N' (or '^') to NOT rerun this pick list. NOTE: Rerunning a pick list deletes all of its old data.",!
QUIT
