- 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 Feb 18, 2025@23:29:19 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
