PSGPLRP ;BIR/CML3-PICK LIST REPRINT DRIVER ;18 APR 95 / 4:20 PM
;;5.0; INPATIENT MEDICATIONS ;**50**;16 DEC 97
;
D ENCV^PSGSETU I $D(XQUIT) Q
;
START ;
R !!,"Select WARD GROUP or PICK LIST: ",X:DTIME W:'$T $C(7) S:'$T X="^" G:"^"[X DONE
I X=+X,$D(^PS(53.5,X,0)) S PSGPLG=X I '$D(^PS(53.5,"AF",PSGPLG)) S Y=^PS(53.5,X,0),PSGPLWG=+$P(Y,U,2),PSGPLWGP=$G(^PS(57.5,PSGPLWG,5)),PSGID=$P(Y,"^",3)
I S PSGOD=$P(Y,"^",4),Y=$S('$D(^PS(57.5,PSGPLWG,0)):PSGPLWG_";PS(57.5",$P(^(0),"^")]"":$P(^(0),"^"),1:PSGPLWG_";PS(57.5") W " ",Y,!?$L(PSGPLG)+21,$$ENDTC^PSGMI(PSGID)," thru ",$$ENDTC^PSGMI(PSGOD) D RP1 G START
D:X?1."?" HLP K DIC S DIC="^PS(57.5,",DIC(0)="EIMQ",DIC("S")="I $D(^PS(57.5,+Y,0)),$P(^(0),""^"",2)=""P"",$D(^PS(53.5,""AB"",+Y))!$D(^PS(53.5,""AO"",+Y))" D ^DIC K DIC G:+Y'>0 START
S PSGPLWG=+Y,PSGPLWGP=$G(^PS(57.5,PSGPLWG,5)) D NOW^%DTC S PSGDT=%,PSGPLGF="P",PSGPLG="" F D ^PSGPLG Q:"^"[PSGPLG D RP1
G START
;
DONE ;
D ENKV^PSGSETU K PSGPLGF,PSGPLG,PSGPLWG,PSGPLWGP,PSGPLUPF,PN,RB,WDN,TM,Y,PSGPLSTR Q
;
RP1 ;
K PSGPLUPF S %=2 I $D(^PS(53.5,"AU",PSGPLG)) D PW Q:%<1
D PAT Q:$D(DUOUT)
I %=2,$D(^PS(53.5,PSGPLG,0)) I '$P(^(0),"^",9) W $C(7),$C(7),!!?33,"*** WARNING ***",!,"THIS PICK LIST STARTED TO RUN ",$$ENDTC^PSGMI($P(^(0),"^",11)),", BUT HAS NOT RUN TO COMPLETION."
K ZTSAVE S ZTDESC="UNIT DOSE PICK LIST REPRINT",PSGTIR="^PSGPLR",(ZTSAVE("PSGPLG"),ZTSAVE("PSGPLWG"),ZTSAVE("PSGPLWGP"),ZTSAVE("PSGPLSTR"))="" S:$D(PSGPLUPF) ZTSAVE("PSGPLUPF")="" S:$D(PSJPRN) ZTSAVE("PSJPRN")=""
D ENDEV^PSGTI I POP W !,"No device selected. Option terminated." Q
I $D(IO("Q")) W:$D(ZTSK) !,"Pick list print queued!" Q
W !!," ...one moment, please..." D ^PSGPLR D ^%ZISC Q
;
HLP ;
W !?2,"Select a Ward Group for which a pick list has run for which you wish to",!,"reprint.",!?2,"You may also select a Pick List by number, which prints in the upper left",!,"corner of each pick list." Q
;
PW ; print which? pick list or update
F W !!,"This pick list has an update.",!,"Do you want to print the update" S %=2 D YN^DICN Q:% W !!?2,"An update has been run for this pick list. Enter 'YES' to print the update",!,"only. Enter 'NO' to print the complete pick list."
S:%=1 PSGPLUPF=1 Q
;
PAT ; select patient to start from
I $G(PSGPLUPF)=1 S DIC("S")="I $P(^(0),U,5)=1"
S PSGPLSTR="",DIC="^PS(53.5,"_PSGPLG_",1,",DIC("A")="Select PATIENT to start from (optional): ",DIC(0)="AEQZ" D ^DIC K DIC Q:Y<0
S WDN=$S($P(^PS(53.5,PSGPLG,0),"^",7)=1:"zns",1:$P(Y(0),"^",3)),TM=$P(Y(0),"^",2)
S RB=$P($G(^PS(53.5,PSGPLG,1,+Y(0),0)),U,4) I RB]"",$P(^PS(53.5,PSGPLG,0),U,6),RB'="zz" S RB=$S($P(RB,"-",2)?1N:0,1:"")_$P(RB,"-",2)_"-"_$P(RB,"-")
S RB=$S($P(^PS(53.5,PSGPLG,0),"^",8)=1:"zz",RB="":"zz",1:RB)
S PN=$E($P($G(^DPT(+Y(0),0)),U),1,12)_U_+Y(0)
Q:'$D(^PS(53.5,"AC",PSGPLG,TM,WDN,RB,PN))
S PSGPLSTR=TM_"^"_WDN_"^"_RB_"^"_PN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGPLRP 2884 printed Oct 16, 2024@18:03:42 Page 2
PSGPLRP ;BIR/CML3-PICK LIST REPRINT DRIVER ;18 APR 95 / 4:20 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**50**;16 DEC 97
+2 ;
+3 DO ENCV^PSGSETU
IF $DATA(XQUIT)
QUIT
+4 ;
START ;
+1 READ !!,"Select WARD GROUP or PICK LIST: ",X:DTIME
if '$TEST
WRITE $CHAR(7)
if '$TEST
SET X="^"
if "^"[X
GOTO DONE
+2 IF X=+X
IF $DATA(^PS(53.5,X,0))
SET PSGPLG=X
IF '$DATA(^PS(53.5,"AF",PSGPLG))
SET Y=^PS(53.5,X,0)
SET PSGPLWG=+$PIECE(Y,U,2)
SET PSGPLWGP=$GET(^PS(57.5,PSGPLWG,5))
SET PSGID=$PIECE(Y,"^",3)
+3 IF $TEST
SET PSGOD=$PIECE(Y,"^",4)
SET Y=$SELECT('$DATA(^PS(57.5,PSGPLWG,0)):PSGPLWG_";PS(57.5",$PIECE(^(0),"^")]"":$PIECE(^(0),"^"),1:PSGPLWG_";PS(57.5")
WRITE " ",Y,!?$LENGTH(PSGPLG)+21,$$ENDTC^PSGMI(PSGID)," thru ",$$ENDTC^PSGMI(PSGOD)
DO RP1
GOTO START
+4 if X?1."?"
DO HLP
KILL DIC
SET DIC="^PS(57.5,"
SET DIC(0)="EIMQ"
SET DIC("S")="I $D(^PS(57.5,+Y,0)),$P(^(0),""^"",2)=""P"",$D(^PS(53.5,""AB"",+Y))!$D(^PS(53.5,""AO"",+Y))"
DO ^DIC
KILL DIC
if +Y'>0
GOTO START
+5 SET PSGPLWG=+Y
SET PSGPLWGP=$GET(^PS(57.5,PSGPLWG,5))
DO NOW^%DTC
SET PSGDT=%
SET PSGPLGF="P"
SET PSGPLG=""
FOR
DO ^PSGPLG
if "^"[PSGPLG
QUIT
DO RP1
+6 GOTO START
+7 ;
DONE ;
+1 DO ENKV^PSGSETU
KILL PSGPLGF,PSGPLG,PSGPLWG,PSGPLWGP,PSGPLUPF,PN,RB,WDN,TM,Y,PSGPLSTR
QUIT
+2 ;
RP1 ;
+1 KILL PSGPLUPF
SET %=2
IF $DATA(^PS(53.5,"AU",PSGPLG))
DO PW
if %<1
QUIT
+2 DO PAT
if $DATA(DUOUT)
QUIT
+3 IF %=2
IF $DATA(^PS(53.5,PSGPLG,0))
IF '$PIECE(^(0),"^",9)
WRITE $CHAR(7),$CHAR(7),!!?33,"*** WARNING ***",!,"THIS PICK LIST STARTED TO RUN ",$$ENDTC^PSGMI($PIECE(^(0),"^",11)),", BUT HAS NOT RUN TO COMPLETION."
+4 KILL ZTSAVE
SET ZTDESC="UNIT DOSE PICK LIST REPRINT"
SET PSGTIR="^PSGPLR"
SET (ZTSAVE("PSGPLG"),ZTSAVE("PSGPLWG"),ZTSAVE("PSGPLWGP"),ZTSAVE("PSGPLSTR"))=""
if $DATA(PSGPLUPF)
SET ZTSAVE("PSGPLUPF")=""
if $DATA(PSJPRN)
SET ZTSAVE("PSJPRN")=""
+5 DO ENDEV^PSGTI
IF POP
WRITE !,"No device selected. Option terminated."
QUIT
+6 IF $DATA(IO("Q"))
if $DATA(ZTSK)
WRITE !,"Pick list print queued!"
QUIT
+7 WRITE !!," ...one moment, please..."
DO ^PSGPLR
DO ^%ZISC
QUIT
+8 ;
HLP ;
+1 WRITE !?2,"Select a Ward Group for which a pick list has run for which you wish to",!,"reprint.",!?2,"You may also select a Pick List by number, which prints in the upper left",!,"corner of each pick list."
QUIT
+2 ;
PW ; print which? pick list or update
+1 FOR
WRITE !!,"This pick list has an update.",!,"Do you want to print the update"
SET %=2
DO YN^DICN
if %
QUIT
WRITE !!?2,"An update has been run for this pick list. Enter 'YES' to print the update",!,"only. Enter 'NO' to print the complete pick list."
+2 if %=1
SET PSGPLUPF=1
QUIT
+3 ;
PAT ; select patient to start from
+1 IF $GET(PSGPLUPF)=1
SET DIC("S")="I $P(^(0),U,5)=1"
+2 SET PSGPLSTR=""
SET DIC="^PS(53.5,"_PSGPLG_",1,"
SET DIC("A")="Select PATIENT to start from (optional): "
SET DIC(0)="AEQZ"
DO ^DIC
KILL DIC
if Y<0
QUIT
+3 SET WDN=$SELECT($PIECE(^PS(53.5,PSGPLG,0),"^",7)=1:"zns",1:$PIECE(Y(0),"^",3))
SET TM=$PIECE(Y(0),"^",2)
+4 SET RB=$PIECE($GET(^PS(53.5,PSGPLG,1,+Y(0),0)),U,4)
IF RB]""
IF $PIECE(^PS(53.5,PSGPLG,0),U,6)
IF RB'="zz"
SET RB=$SELECT($PIECE(RB,"-",2)?1N:0,1:"")_$PIECE(RB,"-",2)_"-"_$PIECE(RB,"-")
+5 SET RB=$SELECT($PIECE(^PS(53.5,PSGPLG,0),"^",8)=1:"zz",RB="":"zz",1:RB)
+6 SET PN=$EXTRACT($PIECE($GET(^DPT(+Y(0),0)),U),1,12)_U_+Y(0)
+7 if '$DATA(^PS(53.5,"AC",PSGPLG,TM,WDN,RB,PN))
QUIT
+8 SET PSGPLSTR=TM_"^"_WDN_"^"_RB_"^"_PN
+9 QUIT
