PSGPLD ;BIR/CML3-DELETE A PICK LIST ;14 OCT 97 / 9:57 AM
;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
;
D ENCV^PSGSETU I $D(XQUIT) Q
K DIC F S DIC="^PS(57.5,",DIC(0)="QEAM",DIC("S")="I $P(^(0),""^"",2)=""P""" W ! D ^DIC K DIC G:Y'>0 DONE Q:$S($D(^PS(53.5,"AB",+Y))&$D(^PS(57.5,+Y,2)):^(2)]"",1:0) W !!,"NO PICK LIST FOUND FOR THIS WARD GROUP."
S WG=+Y,WGN=$P(Y,"^",2),RU=^PS(57.5,WG,2),PLP=+RU I '$$LOCK^PSGPLUTL(PLP,"PSGPL") W $C(7),$C(7),!!," *** THE LATEST PICK LIST FOR THIS WARD GROUP IS CURRENTLY RUNNING! ***" G PSGPLD
I $D(^PS(53.5,"AF",PLP)) W !!,"THE LATEST PICK LIST FOR THIS WARD GROUP IS BEING FILED AWAY." D ENQ^PSGPLDP,UNLOCK^PSGPLUTL(PLP,"PSGPL") G PSGPLD
S RD=$P(RU,"^",2),(SD,XD)=$P(RU,"^",3),FD=$P(RU,"^",4),RU=$P(RU,"^",5),RUN=$P($G(^VA(200,+RU,0)),"^") S:RUN="" RUN=RU F X="FD","RD","SD" S @X=$$ENDTC^PSGMI(@X)
I $D(^PS(53.5,"AO",WG,XD,PLP)) W !!,"THE LATEST PICK LIST FOR THIS WARD GROUP HAS ALREADY BEEN FILED AWAY." D UNLOCK^PSGPLUTL(PLP,"PSGPL") G PSGPLD
D INFO F W !!,"DO YOU WANT TO DELETE THIS PICK LIST" S %=0 D YN^DICN Q:% D:%Y?1."?" QUES W:%Y'?1."?" $C(7)," (Answer required.)"
I %'=1 D UNLOCK^PSGPLUTL(PLP,"PSGPL") G PSGPLD
W !!,"...a few moments, please..."
F L +^PS(57.5,WG,2):0 I D Q
.; Naked Ref. below is from the lock on the line below
.S ^(2)=$P(^PS(57.5,WG,2),"^",6,15) K ^PS(53.5,PLP),^PS(53.5,"AC",PLP),^PS(53.5,"AU",PLP),^PS(53.5,"A",WG,PLP),^PS(53.5,"B",PLP),^PS(53.5,"AB",WG,XD,PLP),^PS(53.5,"AO",WG,XD,PLP),^PS(53.5,"AF",PLP) W "." D:RU'=DUZ MMSG W "." Q
L -^PS(57.5,WG,2) D UNLOCK^PSGPLUTL(PLP,"PSGPL") W ".DONE!"
;
DONE ;
D ENKV^PSGSETU K FD,L,PLP,RD,RU,RUN,SD,WG,WGN,XD,XMZ Q
;
QUES ;
W !!," Enter a 'Y' to delete this Pick List. Enter an 'N' to leave this Pick List asit is. PLEASE NOTE that deleted Pick Lists are gone completely and are",!,"irretrievable." Q:%Y'?2."?"
;
INFO ;
W !!,"The last Pick List was last run for ",WGN,!,"by ",$S(RU'=RUN:RUN,1:RUN_" (NOT FOUND)")," on ",RD,!,"Pick List number ",PLP,", for ",SD," through ",FD,"." Q
;
MMSG ;
K PSG S ND=$P($G(^VA(200,DUZ,0)),"^") S:ND="" ND=DUZ
S XMSUB="PICK LIST DELETION",XMTEXT="PSG(",XMDUZ="MEDICATIONS,UNIT DOSE" K XMY S (XMY(RU),XMY(+DUZ))=1 F Q=0:0 S Q=$O(^XUSEC("PSJU MGR",Q)) Q:'Q S XMY(Q)=""
; I 'XMDUZ D ENNU^PSGPLFM S XMDUZ=$O(^VA(200,"B","MEDICATIONS,UNIT DOSE",0))
S X=" "_ND_" has deleted the Pick List for ward group "_WGN_" run by "_RUN_" on "_RD_". The coverage dates for this pick list were "_SD_" through "_FD_"."
S Y=1,PSG(1,0)=" " F Q=1:1 Q:$P(X," ",Q,999)="" X:$L(PSG(Y,0))+$L($P(X," ",Q))>72 "S Y=Y+1,PSG(Y,0)=""""" S PSG(Y,0)=PSG(Y,0)_$P(X," ",Q)_" "
D ^XMD K ND,PSG Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGPLD 2678 printed Oct 16, 2024@18:03:32 Page 2
PSGPLD ;BIR/CML3-DELETE A PICK LIST ;14 OCT 97 / 9:57 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
+2 ;
+3 DO ENCV^PSGSETU
IF $DATA(XQUIT)
QUIT
+4 KILL DIC
FOR
SET DIC="^PS(57.5,"
SET DIC(0)="QEAM"
SET DIC("S")="I $P(^(0),""^"",2)=""P"""
WRITE !
DO ^DIC
KILL DIC
if Y'>0
GOTO DONE
if $SELECT($DATA(^PS(53.5,"AB",+Y))&$DATA(^PS(57.5,+Y,2))
QUIT
WRITE !!,"NO PICK LIST FOUND FOR THIS WARD GROUP."
+5 SET WG=+Y
SET WGN=$PIECE(Y,"^",2)
SET RU=^PS(57.5,WG,2)
SET PLP=+RU
IF '$$LOCK^PSGPLUTL(PLP,"PSGPL")
WRITE $CHAR(7),$CHAR(7),!!," *** THE LATEST PICK LIST FOR THIS WARD GROUP IS CURRENTLY RUNNING! ***"
GOTO PSGPLD
+6 IF $DATA(^PS(53.5,"AF",PLP))
WRITE !!,"THE LATEST PICK LIST FOR THIS WARD GROUP IS BEING FILED AWAY."
DO ENQ^PSGPLDP
DO UNLOCK^PSGPLUTL(PLP,"PSGPL")
GOTO PSGPLD
+7 SET RD=$PIECE(RU,"^",2)
SET (SD,XD)=$PIECE(RU,"^",3)
SET FD=$PIECE(RU,"^",4)
SET RU=$PIECE(RU,"^",5)
SET RUN=$PIECE($GET(^VA(200,+RU,0)),"^")
if RUN=""
SET RUN=RU
FOR X="FD","RD","SD"
SET @X=$$ENDTC^PSGMI(@X)
+8 IF $DATA(^PS(53.5,"AO",WG,XD,PLP))
WRITE !!,"THE LATEST PICK LIST FOR THIS WARD GROUP HAS ALREADY BEEN FILED AWAY."
DO UNLOCK^PSGPLUTL(PLP,"PSGPL")
GOTO PSGPLD
+9 DO INFO
FOR
WRITE !!,"DO YOU WANT TO DELETE THIS PICK LIST"
SET %=0
DO YN^DICN
if %
QUIT
if %Y?1."?"
DO QUES
if %Y'?1."?"
WRITE $CHAR(7)," (Answer required.)"
+10 IF %'=1
DO UNLOCK^PSGPLUTL(PLP,"PSGPL")
GOTO PSGPLD
+11 WRITE !!,"...a few moments, please..."
+12 FOR
LOCK +^PS(57.5,WG,2):0
IF $TEST
Begin DoDot:1
+13 ; Naked Ref. below is from the lock on the line below
+14 SET ^(2)=$PIECE(^PS(57.5,WG,2),"^",6,15)
KILL ^PS(53.5,PLP),^PS(53.5,"AC",PLP),^PS(53.5,"AU",PLP),^PS(53.5,"A",WG,PLP),^PS(53.5,"B",PLP),^PS(53.5,"AB",WG,XD,PLP),^PS(53.5,"AO",WG,XD,PLP),^PS(53.5,"AF",PLP)
WRITE "."
if RU'=DUZ
DO MMSG
WRITE "."
QUIT
End DoDot:1
QUIT
+15 LOCK -^PS(57.5,WG,2)
DO UNLOCK^PSGPLUTL(PLP,"PSGPL")
WRITE ".DONE!"
+16 ;
DONE ;
+1 DO ENKV^PSGSETU
KILL FD,L,PLP,RD,RU,RUN,SD,WG,WGN,XD,XMZ
QUIT
+2 ;
QUES ;
+1 WRITE !!," Enter a 'Y' to delete this Pick List. Enter an 'N' to leave this Pick List asit is. PLEASE NOTE that deleted Pick Lists are gone completely and are",!,"irretrievable."
if %Y'?2."?"
QUIT
+2 ;
INFO ;
+1 WRITE !!,"The last Pick List was last run for ",WGN,!,"by ",$SELECT(RU'=RUN:RUN,1:RUN_" (NOT FOUND)")," on ",RD,!,"Pick List number ",PLP,", for ",SD," through ",FD,"."
QUIT
+2 ;
MMSG ;
+1 KILL PSG
SET ND=$PIECE($GET(^VA(200,DUZ,0)),"^")
if ND=""
SET ND=DUZ
+2 SET XMSUB="PICK LIST DELETION"
SET XMTEXT="PSG("
SET XMDUZ="MEDICATIONS,UNIT DOSE"
KILL XMY
SET (XMY(RU),XMY(+DUZ))=1
FOR Q=0:0
SET Q=$ORDER(^XUSEC("PSJU MGR",Q))
if 'Q
QUIT
SET XMY(Q)=""
+3 ; I 'XMDUZ D ENNU^PSGPLFM S XMDUZ=$O(^VA(200,"B","MEDICATIONS,UNIT DOSE",0))
+4 SET X=" "_ND_" has deleted the Pick List for ward group "_WGN_" run by "_RUN_" on "_RD_". The coverage dates for this pick list were "_SD_" through "_FD_"."
+5 SET Y=1
SET PSG(1,0)=" "
FOR Q=1:1
if $PIECE(X," ",Q,999)=""
QUIT
if $LENGTH(PSG(Y,0))+$LENGTH($PIECE(X," ",Q))>72
XECUTE "S Y=Y+1,PSG(Y,0)="""""
SET PSG(Y,0)=PSG(Y,0)_$PIECE(X," ",Q)_" "
+6 DO ^XMD
KILL ND,PSG
QUIT
