PSGPLDP ;BIR/CML3-ENTER AND FILE UNITS DISPENSED ;15 JAN 97 / 11:13 AM
;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
;
D ENCV^PSGSETU Q:$D(XQUIT) S PSGPLGF="D",PRN=""
CHK ;
D NOW^%DTC S PSGDT=% F Q=0:0 S Q=$O(^PS(53.5,"AB",Q)) Q:'Q Q:$O(^(Q,0))
I 'Q W !,"NO PICK LIST AVAILABLE",$S($D(^PS(53.5,"AB")):", YET.",1:".") G DONE
ASK R !!,"Select WARD GROUP or PICK LIST: ",X:DTIME W:'$T $C(7) S:'$T X="^" G:"^"[X DONE I X=+X D NL I Y D RUN1 G CHK
;D:X?1."?" HLP S DIC(0)="EIMQZ",DIC="^PS(57.5,",DIC("S")="I $P($G(^PS(57.5,+Y,0)),""^"",2)=""P"",$D(^PS(53.5,""AB"",+Y)),$O(^(+Y,0))<"_PSGDT D ^DIC K DIC G:Y'>0 ASK S (WG,PSGPLWG)=+Y,PSGPLWGN=Y(0,0) D RUN G CHK
D:X?1."?" HLP S DIC(0)="EIMQZ",DIC="^PS(57.5,",DIC("S")="I $P($G(^PS(57.5,+Y,0)),""^"",2)=""P"",$D(^PS(53.5,""AB"",+Y))" D ^DIC K DIC G:Y'>0 ASK S (WG,PSGPLWG)=+Y,PSGPLWGN=Y(0,0) D RUN G CHK
;
DONE ;
D:$D(^PS(53.5,"AF")) ENQ D ENKV^PSGSETU K AM,DR,DRG,FA,LMT,OK,PSGLCNT,PSJJORD,PC,PDD,PDN,PN,PND,PPN,PR,PRN,PSGP,PSGPLG,PSGPLGF,PSGPLTND,PSGPLWG,PSGPLWGN,PW,Q,RB,SCH,PSSN,ST,TM,WDN,WF,WSF,WG,X,Y Q
;
RUN ; choose pick list and go through it
D ^PSGPLG Q:"^"[PSGPLG D RUN1
Q
;
RUN1 ;
I '$$LOCK^PSGPLUTL(PSGPLG,"PSGPL") W $C(7),!!,"Another terminal is acccessing this pick list." Q
I $O(^PS(53.5,PSGPLG,0))="" D AF
I $O(^PS(53.5,PSGPLG,0))]"" D ^PSGPLDP0
D UNLOCK^PSGPLUTL(PSGPLG,"PSGPL") Q
;
AF ;
;*** what are the AO and AB xrefs that follow?
W !!?3,"*** NO DATA" D NOW^%DTC S Y=+$P(^PS(53.5,PSGPLG,0),"^",3) I $S('Y:1,1:%>Y) S $P(^(0),"^",5)=2,^PS(53.5,"AO",PSGPLWG,Y,PSGPLG)="" K ^PS(53.5,"AB",PSGPLWG,Y,PSGPLG) W " (PICK LIST AUTOMATICALLY FILED AWAY)"
W " ***" Q
;
ENQ ; queue PSGPLF
D NOW^%DTC S AM=15 F L +^PS(59.7,1,63.5):0 I S X=$P($G(^PS(59.7,1,63.5)),"^",4),ST=$S(X>%:X,1:%),X=$$EN^PSGCT(ST,AM) S $P(^PS(59.7,1,63.5),"^",4)=X L -^PS(59.7,1,63.5) Q
S PSGTID=X,PSGTIR="EN^PSGPLF",ZTDESC="FILE AWAY PICK LIST",ZTIO="" K ZTSAVE D ENNOIO^PSGTI Q
;
NL ; numeric look-up
S Y=$G(^PS(53.5,X,0)) I $S('Y:1,'$P(Y,"^",2):1,1:'$D(^PS(53.5,"AB",$P(Y,"^",2),+$P(Y,"^",3),X))) S Y=0 Q
S PSGPLG=X,X=^PS(53.5,PSGPLG,0),Y=$$ENDTC^PSGMI($P(X,"^",3)),PSGPLWG=$P(X,"^",2),PSGPLWGN=$S('$D(^PS(57.5,PSGPLWG,0)):PSGPLWG_";PS(57.5,",$P(^(0),"^")]"":$P(^(0),"^"),1:PSGPLWG_";PS(57.5,"),PSGOD=$$ENDTC^PSGMI($P(X,"^",4))
W " ",PSGPLWGN,!?$L(PSGPLWG)+21,Y," thru ",PSGOD S Y=1 Q
;
HLP ;
W !?2,"Select a Ward Group for which a pick list has run for which you wish to enter",!,"the units actually dispensed.",!?2,"You may also select a pick list by its number, which prints in the upper left",!,"corner of each pick list." Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGPLDP 2627 printed Oct 16, 2024@18:03:33 Page 2
PSGPLDP ;BIR/CML3-ENTER AND FILE UNITS DISPENSED ;15 JAN 97 / 11:13 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
+2 ;
+3 DO ENCV^PSGSETU
if $DATA(XQUIT)
QUIT
SET PSGPLGF="D"
SET PRN=""
CHK ;
+1 DO NOW^%DTC
SET PSGDT=%
FOR Q=0:0
SET Q=$ORDER(^PS(53.5,"AB",Q))
if 'Q
QUIT
if $ORDER(^(Q,0))
QUIT
+2 IF 'Q
WRITE !,"NO PICK LIST AVAILABLE",$SELECT($DATA(^PS(53.5,"AB")):", YET.",1:".")
GOTO DONE
ASK READ !!,"Select WARD GROUP or PICK LIST: ",X:DTIME
if '$TEST
WRITE $CHAR(7)
if '$TEST
SET X="^"
if "^"[X
GOTO DONE
IF X=+X
DO NL
IF Y
DO RUN1
GOTO CHK
+1 ;D:X?1."?" HLP S DIC(0)="EIMQZ",DIC="^PS(57.5,",DIC("S")="I $P($G(^PS(57.5,+Y,0)),""^"",2)=""P"",$D(^PS(53.5,""AB"",+Y)),$O(^(+Y,0))<"_PSGDT D ^DIC K DIC G:Y'>0 ASK S (WG,PSGPLWG)=+Y,PSGPLWGN=Y(0,0) D RUN G CHK
+2 if X?1."?"
DO HLP
SET DIC(0)="EIMQZ"
SET DIC="^PS(57.5,"
SET DIC("S")="I $P($G(^PS(57.5,+Y,0)),""^"",2)=""P"",$D(^PS(53.5,""AB"",+Y))"
DO ^DIC
KILL DIC
if Y'>0
GOTO ASK
SET (WG,PSGPLWG)=+Y
SET PSGPLWGN=Y(0,0)
DO RUN
GOTO CHK
+3 ;
DONE ;
+1 if $DATA(^PS(53.5,"AF"))
DO ENQ
DO ENKV^PSGSETU
KILL AM,DR,DRG,FA,LMT,OK,PSGLCNT,PSJJORD,PC,PDD,PDN,PN,PND,PPN,PR,PRN,PSGP,PSGPLG,PSGPLGF,PSGPLTND,PSGPLWG,PSGPLWGN,PW,Q,RB,SCH,PSSN,ST,TM,WDN,WF,WSF,WG,X,Y
QUIT
+2 ;
RUN ; choose pick list and go through it
+1 DO ^PSGPLG
if "^"[PSGPLG
QUIT
DO RUN1
+2 QUIT
+3 ;
RUN1 ;
+1 IF '$$LOCK^PSGPLUTL(PSGPLG,"PSGPL")
WRITE $CHAR(7),!!,"Another terminal is acccessing this pick list."
QUIT
+2 IF $ORDER(^PS(53.5,PSGPLG,0))=""
DO AF
+3 IF $ORDER(^PS(53.5,PSGPLG,0))]""
DO ^PSGPLDP0
+4 DO UNLOCK^PSGPLUTL(PSGPLG,"PSGPL")
QUIT
+5 ;
AF ;
+1 ;*** what are the AO and AB xrefs that follow?
+2 WRITE !!?3,"*** NO DATA"
DO NOW^%DTC
SET Y=+$PIECE(^PS(53.5,PSGPLG,0),"^",3)
IF $SELECT('Y:1,1:%>Y)
SET $PIECE(^(0),"^",5)=2
SET ^PS(53.5,"AO",PSGPLWG,Y,PSGPLG)=""
KILL ^PS(53.5,"AB",PSGPLWG,Y,PSGPLG)
WRITE " (PICK LIST AUTOMATICALLY FILED AWAY)"
+3 WRITE " ***"
QUIT
+4 ;
ENQ ; queue PSGPLF
+1 DO NOW^%DTC
SET AM=15
FOR
LOCK +^PS(59.7,1,63.5):0
IF $TEST
SET X=$PIECE($GET(^PS(59.7,1,63.5)),"^",4)
SET ST=$SELECT(X>%:X,1:%)
SET X=$$EN^PSGCT(ST,AM)
SET $PIECE(^PS(59.7,1,63.5),"^",4)=X
LOCK -^PS(59.7,1,63.5)
QUIT
+2 SET PSGTID=X
SET PSGTIR="EN^PSGPLF"
SET ZTDESC="FILE AWAY PICK LIST"
SET ZTIO=""
KILL ZTSAVE
DO ENNOIO^PSGTI
QUIT
+3 ;
NL ; numeric look-up
+1 SET Y=$GET(^PS(53.5,X,0))
IF $SELECT('Y:1,'$PIECE(Y,"^",2):1,1:'$DATA(^PS(53.5,"AB",$PIECE(Y,"^",2),+$PIECE(Y,"^",3),X)))
SET Y=0
QUIT
+2 SET PSGPLG=X
SET X=^PS(53.5,PSGPLG,0)
SET Y=$$ENDTC^PSGMI($PIECE(X,"^",3))
SET PSGPLWG=$PIECE(X,"^",2)
SET PSGPLWGN=$SELECT('$DATA(^PS(57.5,PSGPLWG,0)):PSGPLWG_";PS(57.5,",$PIECE(^(0),"^")]"":$PIECE(^(0),"^"),1:PSGPLWG_";PS(57.5,")
SET PSGOD=$$ENDTC^PSGMI($PIECE(X,"^",4))
+3 WRITE " ",PSGPLWGN,!?$LENGTH(PSGPLWG)+21,Y," thru ",PSGOD
SET Y=1
QUIT
+4 ;
HLP ;
+1 WRITE !?2,"Select a Ward Group for which a pick list has run for which you wish to enter",!,"the units actually dispensed.",!?2,"You may also select a pick list by its number, which prints in the upper left",!,"corner of each pick list."
QUIT
