| 1 | PSGPLD ;BIR/CML3-DELETE A PICK LIST ;14 OCT 97 / 9:57 AM
|
|---|
| 2 | ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
|
|---|
| 3 | ;
|
|---|
| 4 | D ENCV^PSGSETU I $D(XQUIT) Q
|
|---|
| 5 | 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."
|
|---|
| 6 | 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
|
|---|
| 7 | 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
|
|---|
| 8 | 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)
|
|---|
| 9 | 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
|
|---|
| 10 | 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.)"
|
|---|
| 11 | I %'=1 D UNLOCK^PSGPLUTL(PLP,"PSGPL") G PSGPLD
|
|---|
| 12 | W !!,"...a few moments, please..."
|
|---|
| 13 | F L +^PS(57.5,WG,2):0 I D Q
|
|---|
| 14 | .; Naked Ref. below is from the lock on the line below
|
|---|
| 15 | .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
|
|---|
| 16 | L -^PS(57.5,WG,2) D UNLOCK^PSGPLUTL(PLP,"PSGPL") W ".DONE!"
|
|---|
| 17 | ;
|
|---|
| 18 | DONE ;
|
|---|
| 19 | D ENKV^PSGSETU K FD,L,PLP,RD,RU,RUN,SD,WG,WGN,XD,XMZ Q
|
|---|
| 20 | ;
|
|---|
| 21 | QUES ;
|
|---|
| 22 | 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."?"
|
|---|
| 23 | ;
|
|---|
| 24 | INFO ;
|
|---|
| 25 | 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
|
|---|
| 26 | ;
|
|---|
| 27 | MMSG ;
|
|---|
| 28 | K PSG S ND=$P($G(^VA(200,DUZ,0)),"^") S:ND="" ND=DUZ
|
|---|
| 29 | 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)=""
|
|---|
| 30 | ; I 'XMDUZ D ENNU^PSGPLFM S XMDUZ=$O(^VA(200,"B","MEDICATIONS,UNIT DOSE",0))
|
|---|
| 31 | 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_"."
|
|---|
| 32 | 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)_" "
|
|---|
| 33 | D ^XMD K ND,PSG Q
|
|---|
