- 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
- 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
