PSGL ;BIR/CML3-LABEL PRINT/REPRINT ;25 SEP 97 / 7:41 AM
;;5.0; INPATIENT MEDICATIONS ;**31,111**;16 DEC 97
;
; Reference to ^PS(55 is supported by DBIA# 2191
;
N PSGPTMP,PSJNEW,PPAGE,PSGEFN S PSJNEW=1
D ENCV^PSGSETU Q:$D(XQUIT) K PSGLSTOP S %=1 F PSGTOL=1,3 I $O(^PS(53.41,PSGTOL,1,0)) D ENACL^PSGL0
G:%<0 DONE
CHK ;
I '$O(^PS(53.41,2,1,DUZ,1,0)) G ASK
F W !!,"You have unprinted new labels. Do you want them now" S %=1 D YN^DICN Q:% D CHKM^PSGLH
G:%<0 DONE I %=1 D ENNL^PSGL0 G ASK
F W !!,"Will you want them later" S %=1 D YN^DICN Q:% D LM^PSGLH
G:%<0 DONE I %=2 S DIK="^PS(53.41,2,1,",DA=DUZ,DA(1)=2 D ^DIK
;
ASK ;
S PSGSSH="LBL" F D ^PSGSEL Q:"^"[PSGSS K PSGLWD,PSGLWG S PSGPTMP=0,PPAGE=1 D @PSGSS Q:+Y'>0 K ZTSAVE,IO("Q") S POP=0,Y=1 D:PSGSS'="P" DT Q:Y'>0 D:PSGSS'="P" DEV Q:POP!$D(IO("Q")) D @("EN"_PSGSS) D ^%ZISC
;
DONE ;
D ENKV^PSGSETU K CF,DFN,NG,OD,ON,PSGCNT,PSGLMT,PSGODDD,PSGOL,PSGON,PSGOP,PSGORD,PSGODT,PSGSS,PSGPL1,PSGPL2,PSGPL3,PSGSSH,PSIVREA,PSJON,PSJOL,PSJORD,PSJIVOF,PSJOCNT,PSJON,RF,QO,QS,QSD,Q1,Q2,WG,ZTSAVE
K ORPV,ORSTOP,ORSTRT,ORSTS,P17 Q
;
DEV ;
K ZTSK,%ZIS,IOP,IO("Q") S PSGION=ION,%ZIS="Q",%ZIS("A")="Label Printing Device: ",%ZIS("B")=$P(PSJSYSL,"^",2) W ! D ^%ZIS K %ZIS I POP S IOP=PSGION D ^%ZIS K IOP S POP=1 W !?3,"(No device chosen for label print.)" Q
D EN2^PSGLBA S POP=0 Q:'$D(IO("Q"))
S ZTDESC="UD LABEL PRINT",PSGTIR=$S(PSGSS'="P":"EN"_PSGSS,1:"ENPLP")_"^PSGL" I PSGSS="G" F X="PSGLBLD","PSGLWG","PSGLWGN" S ZTSAVE(X)=""
I PSGSS="W" F X="PSGLBLD","PSGLWD","PSGLWDN" S ZTSAVE(X)=""
I PSGSS="P" F X="PSGP","PSGP(0)","PSJPAGE","PSJPDOB","PSJPDX","PSJPRB","PSJPSEX","PSJPSSN","PSJPWD","PSJPWDN","PSGODDD","PSGODDD(","VA(""PID"")","VA(""BID"")","^TMP(""PSJON"",$J," S ZTSAVE(X)=""
W ! D ENTSK^PSGTI W !,"Labels ",$S($D(ZTSK):"",1:"NOT "),"queued!"
Q
;
G ;
K DIC S DIC="^PS(57.5,",DIC(0)="QEAMIZ",DIC("A")="Select WARD GROUP: " W ! D ^DIC K DIC D Q
. I X="^OTHER" S (PSGLWG,PSGLWGN)="^OTHER",Y=1 Q
. I Y>0 S PSGLWG=+Y,PSGLWGN=Y(0,0)
;
W ;
K DIC S DIC="^DIC(42,",DIC(0)="QEAMIZ",DIC("A")="Select WARD: " W ! D ^DIC K DIC S:Y>0 PSGLWD=+Y,PSGLWDN=Y(0,0) Q
;
P ;
K PSJPR D ^PSJP S Y=PSGP Q
;
C ;
K DIR S DIR(0)="FAO",DIR("A")="Select CLINIC: "
S DIR("?")="^D CDIC^PSGVBW" W ! D ^DIR
CDIC ;
K DIC S DIC="^SC(",DIC(0)="QEMIZ" D ^DIC K DIC S:+Y>0 CL=+Y
W:X["?" !!,"Enter the clinic you want to use to select patients for processing.",!
Q
L ;
K DIR S DIR(0)="FAO",DIR("A")="Select CLINIC GROUP: "
S DIR("?")="^D LDIC^PSGVBW" W ! D ^DIR
LDIC ;
K DIC S DIC="^PS(57.8,",DIC(0)="QEMI" D ^DIC K DIC S:+Y>0 CG=+Y
W:X["?" !!,"Enter the name of the clinic group you want to use to select patients for processing."
Q
ENG ;
F PSGLWD=0:0 S PSGLWD=$O(^PS(57.5,"AC",PSGLWG,PSGLWD)) Q:'PSGLWD S PSGLWDN=$P($G(^DIC(42,PSGLWD,0)),"^") D ENW1
Q
;
ENW ;
S PSGLWG=$O(^PS(57.5,"AB",PSGLWD,0)),PSGLWGN="" I PSGLWG,$D(^PS(57.5,PSGLWG,0)),$P(^(0),"^")]"" S PSGLWG=$P(^(0),"^")
;
ENW1 ;
D NOW^%DTC S PSGDT=% U IO F PSGOP=0:0 S (DFN,PSGOP,PSGP)=$O(^DPT("CN",PSGLWDN,PSGOP)) Q:'PSGOP D IWP
Q
IWP ;
N PSJFIRST,PSJACND S (PSJACND,PSJFIRST)=1 K PSJACNWP D ^PSJAC,ENPVSET^PSGLPI
F QSD=PSGLAD:0 S QSD=$O(^PS(55,PSGOP,5,"AUS",QSD)) Q:'QSD F ON=0:0 S ON=$O(^PS(55,PSGOP,5,"AUS",QSD,ON)) Q:'ON D
.I PSJFIRST,$P(PSJSYSW0,U,18) D ENHEDER^PSGLPI S PSJFIRST=0
.I $D(^PS(55,PSGOP,5,ON,7)),+^(7)'<PSGLBLD S PSGORD=ON_"A" D ^PSGLOI,KL
F ON=0:0 S ON=$O(^PS(53.1,"AC",PSGOP,ON)) Q:'ON D
.I PSJFIRST,$P(PSJSYSW0,U,18) D ENHEDER^PSGLPI S PSJFIRST=0
.I $D(^PS(53.1,ON,7)),+^(7)'<PSGLBLD S PSGORD=ON_"N" D ^PSGLOI,KL
Q
;
ENL S CL="" F S CL=$O(^PS(57.8,"AD",CG,CL)) Q:CL="" D ENC
Q
ENC ;
K ^TMP("PSJCI",$J)
S STDTE=0 F S STDTE=$O(^PS(55,"AUDC",STDTE)) Q:'STDTE S CLINIC=0 F S CLINIC=$O(^PS(55,"AUDC",STDTE,CLINIC)) Q:'CLINIC D
. S JDFN=0 F S JDFN=$O(^PS(55,"AUDC",STDTE,CLINIC,JDFN)) Q:'JDFN S ^TMP("PSJCI",$J,JDFN)=""
S DFN="" F S DFN=$O(^TMP("PSJCI",$J,DFN)) Q:'DFN S (PSGOP,PSGP)=DFN D IWP
Q
ENP ;
;D ENL^PSJO3 Q:"^N"[PSJOL S PSJOS=$P(PSJSYSP0,"^",11),PSGLPF=1 D ^PSJO K PSGLPF Q:'PSJON S PSGLMT=PSJON
D ENL^PSJO3 Q:"^N"[PSJOL S PSJOS=$P(PSJSYSP0,"^",11) D ^PSJO K PSGLPF Q:'PSJON S PSGLMT=PSJON
F R !!,"Select orders for labels: ",X:DTIME W:'$T $C(7) S:'$T X="^" Q:"^"[X D Q:$D(X)
.I X?2."?" D H2^PSGON K X Q
.I X?1."?" W !!?2,"Select the orders for which you want labels printed." K X Q
.I X="A" D AADR^PSJUTL K X Q
.I X'?1."?" D ^PSGON W:'$D(X) $C(7)," ??" Q
I "^"[X K ^TMP("PSJON",$J) Q
D DEV I POP!$D(IO("Q")) K ^TMP("PSJON",$J) Q
;
ENPLP ;
D NOW^%DTC S PSGDT=+$E(%,1,12),(DFN,PSGOP)=PSGP D:$D(ZTSK) ^PSJAC D ENPVSET^PSGLPI U IO
N PSJFIRST S PSJFIRST=1 F PSGPL1=1:1:PSGODDD F PSGPL2=1:1 S PSGPL3=$P(PSGODDD(PSGPL1),",",PSGPL2) Q:'PSGPL3 S (PSGORD,PSJORD)=^TMP("PSJON",$J,PSGPL3) D
.I PSJFIRST,$P(PSJSYSW0,U,18) D ENHEDER^PSGLPI S PSJFIRST=0
.I PSGORD["V" D EN^PSIVUDL(DFN,PSGORD,PSGLWD_U_PSGLWDN,PSGLRB),KL Q
.I PSGORD'["P" D ^PSGLOI,KL Q
.S X=$P($G(^PS(53.1,+PSGORD,0)),"^",4) I X="F" D EN^PSIVUDL(DFN,PSGORD,PSGLWD_U_PSGLWDN,PSGLRB),KL Q
.D ^PSGLOI,KL
Q
;
DT ;
F K %DT S %DT="ET",%DT(0)="-NOW" R !!,"Enter label start date: ",X:DTIME D:X?1."?" DTM^PSGLH D ^%DT K %DT I Y>0!("^"[X) S PSGLBLD=Y,ZTSAVE("PSGLBLD")="" Q
W:Y'>0 $C(7),!?3,"(No date selected for label print.)" Q
;
KL ; kill other label records for the same order
S QS=$S(PSGORD["V":3,PSGORD["N":2,1:1) K ^PS(53.41,2,1,DUZ,1,PSGOP,1,QS,+PSGORD)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGL 5533 printed Dec 13, 2024@02:01:20 Page 2
PSGL ;BIR/CML3-LABEL PRINT/REPRINT ;25 SEP 97 / 7:41 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**31,111**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA# 2191
+4 ;
+5 NEW PSGPTMP,PSJNEW,PPAGE,PSGEFN
SET PSJNEW=1
+6 DO ENCV^PSGSETU
if $DATA(XQUIT)
QUIT
KILL PSGLSTOP
SET %=1
FOR PSGTOL=1,3
IF $ORDER(^PS(53.41,PSGTOL,1,0))
DO ENACL^PSGL0
+7 if %<0
GOTO DONE
CHK ;
+1 IF '$ORDER(^PS(53.41,2,1,DUZ,1,0))
GOTO ASK
+2 FOR
WRITE !!,"You have unprinted new labels. Do you want them now"
SET %=1
DO YN^DICN
if %
QUIT
DO CHKM^PSGLH
+3 if %<0
GOTO DONE
IF %=1
DO ENNL^PSGL0
GOTO ASK
+4 FOR
WRITE !!,"Will you want them later"
SET %=1
DO YN^DICN
if %
QUIT
DO LM^PSGLH
+5 if %<0
GOTO DONE
IF %=2
SET DIK="^PS(53.41,2,1,"
SET DA=DUZ
SET DA(1)=2
DO ^DIK
+6 ;
ASK ;
+1 SET PSGSSH="LBL"
FOR
DO ^PSGSEL
if "^"[PSGSS
QUIT
KILL PSGLWD,PSGLWG
SET PSGPTMP=0
SET PPAGE=1
DO @PSGSS
if +Y'>0
QUIT
KILL ZTSAVE,IO("Q")
SET POP=0
SET Y=1
if PSGSS'="P"
DO DT
if Y'>0
QUIT
if PSGSS'="P"
DO DEV
if POP!$DATA(IO("Q"))
QUIT
DO @("EN"_PSGSS)
DO ^%ZISC
+2 ;
DONE ;
+1 DO ENKV^PSGSETU
KILL CF,DFN,NG,OD,ON,PSGCNT,PSGLMT,PSGODDD,PSGOL,PSGON,PSGOP,PSGORD,PSGODT,PSGSS,PSGPL1,PSGPL2,PSGPL3,PSGSSH,PSIVREA,PSJON,PSJOL,PSJORD,PSJIVOF,PSJOCNT,PSJON,RF,QO,QS,QSD,Q1,Q2,WG,ZTSAVE
+2 KILL ORPV,ORSTOP,ORSTRT,ORSTS,P17
QUIT
+3 ;
DEV ;
+1 KILL ZTSK,%ZIS,IOP,IO("Q")
SET PSGION=ION
SET %ZIS="Q"
SET %ZIS("A")="Label Printing Device: "
SET %ZIS("B")=$PIECE(PSJSYSL,"^",2)
WRITE !
DO ^%ZIS
KILL %ZIS
IF POP
SET IOP=PSGION
DO ^%ZIS
KILL IOP
SET POP=1
WRITE !?3,"(No device chosen for label print.)"
QUIT
+2 DO EN2^PSGLBA
SET POP=0
if '$DATA(IO("Q"))
QUIT
+3 SET ZTDESC="UD LABEL PRINT"
SET PSGTIR=$SELECT(PSGSS'="P":"EN"_PSGSS,1:"ENPLP")_"^PSGL"
IF PSGSS="G"
FOR X="PSGLBLD","PSGLWG","PSGLWGN"
SET ZTSAVE(X)=""
+4 IF PSGSS="W"
FOR X="PSGLBLD","PSGLWD","PSGLWDN"
SET ZTSAVE(X)=""
+5 IF PSGSS="P"
FOR X="PSGP","PSGP(0)","PSJPAGE","PSJPDOB","PSJPDX","PSJPRB","PSJPSEX","PSJPSSN","PSJPWD","PSJPWDN","PSGODDD","PSGODDD(","VA(""PID"")","VA(""BID"")","^TMP(""PSJON"",$J,"
SET ZTSAVE(X)=""
+6 WRITE !
DO ENTSK^PSGTI
WRITE !,"Labels ",$SELECT($DATA(ZTSK):"",1:"NOT "),"queued!"
+7 QUIT
+8 ;
G ;
+1 KILL DIC
SET DIC="^PS(57.5,"
SET DIC(0)="QEAMIZ"
SET DIC("A")="Select WARD GROUP: "
WRITE !
DO ^DIC
KILL DIC
Begin DoDot:1
+2 IF X="^OTHER"
SET (PSGLWG,PSGLWGN)="^OTHER"
SET Y=1
QUIT
+3 IF Y>0
SET PSGLWG=+Y
SET PSGLWGN=Y(0,0)
End DoDot:1
QUIT
+4 ;
W ;
+1 KILL DIC
SET DIC="^DIC(42,"
SET DIC(0)="QEAMIZ"
SET DIC("A")="Select WARD: "
WRITE !
DO ^DIC
KILL DIC
if Y>0
SET PSGLWD=+Y
SET PSGLWDN=Y(0,0)
QUIT
+2 ;
P ;
+1 KILL PSJPR
DO ^PSJP
SET Y=PSGP
QUIT
+2 ;
C ;
+1 KILL DIR
SET DIR(0)="FAO"
SET DIR("A")="Select CLINIC: "
+2 SET DIR("?")="^D CDIC^PSGVBW"
WRITE !
DO ^DIR
CDIC ;
+1 KILL DIC
SET DIC="^SC("
SET DIC(0)="QEMIZ"
DO ^DIC
KILL DIC
if +Y>0
SET CL=+Y
+2 if X["?"
WRITE !!,"Enter the clinic you want to use to select patients for processing.",!
+3 QUIT
L ;
+1 KILL DIR
SET DIR(0)="FAO"
SET DIR("A")="Select CLINIC GROUP: "
+2 SET DIR("?")="^D LDIC^PSGVBW"
WRITE !
DO ^DIR
LDIC ;
+1 KILL DIC
SET DIC="^PS(57.8,"
SET DIC(0)="QEMI"
DO ^DIC
KILL DIC
if +Y>0
SET CG=+Y
+2 if X["?"
WRITE !!,"Enter the name of the clinic group you want to use to select patients for processing."
+3 QUIT
ENG ;
+1 FOR PSGLWD=0:0
SET PSGLWD=$ORDER(^PS(57.5,"AC",PSGLWG,PSGLWD))
if 'PSGLWD
QUIT
SET PSGLWDN=$PIECE($GET(^DIC(42,PSGLWD,0)),"^")
DO ENW1
+2 QUIT
+3 ;
ENW ;
+1 SET PSGLWG=$ORDER(^PS(57.5,"AB",PSGLWD,0))
SET PSGLWGN=""
IF PSGLWG
IF $DATA(^PS(57.5,PSGLWG,0))
IF $PIECE(^(0),"^")]""
SET PSGLWG=$PIECE(^(0),"^")
+2 ;
ENW1 ;
+1 DO NOW^%DTC
SET PSGDT=%
USE IO
FOR PSGOP=0:0
SET (DFN,PSGOP,PSGP)=$ORDER(^DPT("CN",PSGLWDN,PSGOP))
if 'PSGOP
QUIT
DO IWP
+2 QUIT
IWP ;
+1 NEW PSJFIRST,PSJACND
SET (PSJACND,PSJFIRST)=1
KILL PSJACNWP
DO ^PSJAC
DO ENPVSET^PSGLPI
+2 FOR QSD=PSGLAD:0
SET QSD=$ORDER(^PS(55,PSGOP,5,"AUS",QSD))
if 'QSD
QUIT
FOR ON=0:0
SET ON=$ORDER(^PS(55,PSGOP,5,"AUS",QSD,ON))
if 'ON
QUIT
Begin DoDot:1
+3 IF PSJFIRST
IF $PIECE(PSJSYSW0,U,18)
DO ENHEDER^PSGLPI
SET PSJFIRST=0
+4 IF $DATA(^PS(55,PSGOP,5,ON,7))
IF +^(7)'<PSGLBLD
SET PSGORD=ON_"A"
DO ^PSGLOI
DO KL
End DoDot:1
+5 FOR ON=0:0
SET ON=$ORDER(^PS(53.1,"AC",PSGOP,ON))
if 'ON
QUIT
Begin DoDot:1
+6 IF PSJFIRST
IF $PIECE(PSJSYSW0,U,18)
DO ENHEDER^PSGLPI
SET PSJFIRST=0
+7 IF $DATA(^PS(53.1,ON,7))
IF +^(7)'<PSGLBLD
SET PSGORD=ON_"N"
DO ^PSGLOI
DO KL
End DoDot:1
+8 QUIT
+9 ;
ENL SET CL=""
FOR
SET CL=$ORDER(^PS(57.8,"AD",CG,CL))
if CL=""
QUIT
DO ENC
+1 QUIT
ENC ;
+1 KILL ^TMP("PSJCI",$JOB)
+2 SET STDTE=0
FOR
SET STDTE=$ORDER(^PS(55,"AUDC",STDTE))
if 'STDTE
QUIT
SET CLINIC=0
FOR
SET CLINIC=$ORDER(^PS(55,"AUDC",STDTE,CLINIC))
if 'CLINIC
QUIT
Begin DoDot:1
+3 SET JDFN=0
FOR
SET JDFN=$ORDER(^PS(55,"AUDC",STDTE,CLINIC,JDFN))
if 'JDFN
QUIT
SET ^TMP("PSJCI",$JOB,JDFN)=""
End DoDot:1
+4 SET DFN=""
FOR
SET DFN=$ORDER(^TMP("PSJCI",$JOB,DFN))
if 'DFN
QUIT
SET (PSGOP,PSGP)=DFN
DO IWP
+5 QUIT
ENP ;
+1 ;D ENL^PSJO3 Q:"^N"[PSJOL S PSJOS=$P(PSJSYSP0,"^",11),PSGLPF=1 D ^PSJO K PSGLPF Q:'PSJON S PSGLMT=PSJON
+2 DO ENL^PSJO3
if "^N"[PSJOL
QUIT
SET PSJOS=$PIECE(PSJSYSP0,"^",11)
DO ^PSJO
KILL PSGLPF
if 'PSJON
QUIT
SET PSGLMT=PSJON
+3 FOR
READ !!,"Select orders for labels: ",X:DTIME
if '$TEST
WRITE $CHAR(7)
if '$TEST
SET X="^"
if "^"[X
QUIT
Begin DoDot:1
+4 IF X?2."?"
DO H2^PSGON
KILL X
QUIT
+5 IF X?1."?"
WRITE !!?2,"Select the orders for which you want labels printed."
KILL X
QUIT
+6 IF X="A"
DO AADR^PSJUTL
KILL X
QUIT
+7 IF X'?1."?"
DO ^PSGON
if '$DATA(X)
WRITE $CHAR(7)," ??"
QUIT
End DoDot:1
if $DATA(X)
QUIT
+8 IF "^"[X
KILL ^TMP("PSJON",$JOB)
QUIT
+9 DO DEV
IF POP!$DATA(IO("Q"))
KILL ^TMP("PSJON",$JOB)
QUIT
+10 ;
ENPLP ;
+1 DO NOW^%DTC
SET PSGDT=+$EXTRACT(%,1,12)
SET (DFN,PSGOP)=PSGP
if $DATA(ZTSK)
DO ^PSJAC
DO ENPVSET^PSGLPI
USE IO
+2 NEW PSJFIRST
SET PSJFIRST=1
FOR PSGPL1=1:1:PSGODDD
FOR PSGPL2=1:1
SET PSGPL3=$PIECE(PSGODDD(PSGPL1),",",PSGPL2)
if 'PSGPL3
QUIT
SET (PSGORD,PSJORD)=^TMP("PSJON",$JOB,PSGPL3)
Begin DoDot:1
+3 IF PSJFIRST
IF $PIECE(PSJSYSW0,U,18)
DO ENHEDER^PSGLPI
SET PSJFIRST=0
+4 IF PSGORD["V"
DO EN^PSIVUDL(DFN,PSGORD,PSGLWD_U_PSGLWDN,PSGLRB)
DO KL
QUIT
+5 IF PSGORD'["P"
DO ^PSGLOI
DO KL
QUIT
+6 SET X=$PIECE($GET(^PS(53.1,+PSGORD,0)),"^",4)
IF X="F"
DO EN^PSIVUDL(DFN,PSGORD,PSGLWD_U_PSGLWDN,PSGLRB)
DO KL
QUIT
+7 DO ^PSGLOI
DO KL
End DoDot:1
+8 QUIT
+9 ;
DT ;
+1 FOR
KILL %DT
SET %DT="ET"
SET %DT(0)="-NOW"
READ !!,"Enter label start date: ",X:DTIME
if X?1."?"
DO DTM^PSGLH
DO ^%DT
KILL %DT
IF Y>0!("^"[X)
SET PSGLBLD=Y
SET ZTSAVE("PSGLBLD")=""
QUIT
+2 if Y'>0
WRITE $CHAR(7),!?3,"(No date selected for label print.)"
QUIT
+3 ;
KL ; kill other label records for the same order
+1 SET QS=$SELECT(PSGORD["V":3,PSGORD["N":2,1:1)
KILL ^PS(53.41,2,1,DUZ,1,PSGOP,1,QS,+PSGORD)
+2 QUIT
