- PSGL0 ;BIR/CML3-ACTUAL LABEL PRINT ; 26 Jun 98 / 8:30 AM
- ;;5.0; INPATIENT MEDICATIONS ;**7**;16 DEC 97
- ENACL ;
- W !!,"There are unprinted new labels from AUTO ",$S(PSGTOL=3:"REINSTATED",1:"DISCONTINUED")," orders." F W !,"Do you want any of them now" S %=1 D YN^DICN Q:% D CHKM^PSGLH
- Q:%<0 I %=1 D ENAC S %=1 Q
- F W !!,"Will you want these labels at a later date" S %=1 D YN^DICN Q:% D LM^PSGLH
- Q:%'=2 S DIK="^PS(53.41,",DA=PSGTOL D ^DIK S %=2 Q
- ;
- ENAC ; select ward
- W !!,"Wards: " S NP="",QQ=0 F W=1:1 S QQ=$O(^PS(53.41,PSGTOL,1,QQ)) Q:'QQ D NP:'(W#20) Q:NP["^" W !,$J(W,3),". ",$S($D(^DIC(42,QQ,0)):$P(^(0),"^"),1:QQ) S W(W)=QQ
- S W=W-1 I 'W K ^PS(53.41,PSGTOL) W !!?3,"Sorry, no labels were found after all. (The problem has been corrected.)",! Q
- F W !!,"Select 1 - ",W,": " R X:DTIME W:'$T $C(7) S:'$T X="^" Q:"^"[X D SC Q:$D(X)
- G:"^"[X DONE S PSGLWARD=PSGODDD F Q=1:1:PSGODDD F Q1=1:1 S Q2=$P(PSGODDD(Q),",",Q1) Q:'Q2 S PSGLWARD(Q)=$S($D(PSGLWARD(Q)):PSGLWARD(Q)_",",1:"")_W(Q2)
- K ZTSAVE S PSGLRTN="ENACP^PSGL0",PSGLDESC="MAR AUTO LABELS",(ZTSAVE("PSGLWARD"),ZTSAVE("PSGLWARD("),ZTSAVE("PSGTOL"))="" D DEV1 I 'POP,'$D(IO("Q")) D ENACP
- G DONE
- ;
- ENNL ; new labels, other than auto discontinue
- K ZTSAVE S PSGLRTN="ENNLP^PSGL0",PSGLDESC="UD NEW LABEL REPRINT" D DEV1 G:POP!$D(IO("Q")) DONE D ENNLP
- ;
- SC ; selection validation
- I X?1."?" W !!," Select (1-",W,") the ward(s) you wish to print labels for. Enter an '^',",!,"or press the RETURN key, to quit now." K X Q
- Q:'$D(W)
- S PSGLMT=W D ^PSGON W:'$D(X) $C(7)," ??" Q
- ;
- DEV1 ; device ask for auto discontinue or new labels
- K IO("Q"),%ZIS,IOP 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 !,"No device selected. Option terminated." Q
- D EN2^PSGLBA S POP=0 I $D(IO("Q")) S PSGTIR=PSGLRTN,ZTDESC=PSGLDESC,(ZTSAVE("PSGLWARD"),ZTSAVE("PSGLWARD("),ZTSAVE("PSGTOL"))="" W ! D ENTSK^PSGTI K PSGLDESC,PSGLRTN W:$D(ZTSK) !?3,"Labels queued!"
- Q
- ;
- ENACP ; auto label print
- D NOW^%DTC S PSGDT=% U IO
- F PSGLWC=1:1:PSGLWARD F PSGLWC1=1:1:$L(PSGLWARD(PSGLWC),",") S PSGLWD=$P(PSGLWARD(PSGLWC),",",PSGLWC1),PSGLWDN=$S($D(^DIC(42,PSGLWD,0)):$P(^(0),"^"),1:"zz") F PSGOP=0:0 S PSGOP=$O(^PS(53.41,PSGTOL,1,PSGLWD,1,PSGOP)) Q:'PSGOP D AC
- Q
- AC ;
- N PSJFIRST,VAINDT S PSJFIRST=1
- F PSGLWC2=1,2,3 F PSGLWC3=0:0 S PSGLWC3=$O(^PS(53.41,PSGTOL,1,PSGLWD,1,PSGOP,1,PSGLWC2,1,PSGLWC3)) Q:'PSGLWC3 S PSGORD=PSGLWC3_$E("ANV",PSGLWC2) D
- .S:PSGTOL'=2 VAINDT=$E($P($G(^PS(53.41,PSGTOL,1,PSGLWD,1,PSGOP,1,PSGLWC2,1,PSGLWC3,0)),U,3),1,12) D ^PSGLPI
- .I PSJFIRST D ENHEDER^PSGLPI S PSJFIRST=0
- .I PSGLWC2=2,($P($G(^PS(53.1,+PSGORD,0)),U,9)="P") S PSGORD=+PSGORD_"P" NEW PSJFLUID S:$P(^(0),U,4)="F" PSJFLUID=1
- .I PSGLWC2=3!$G(PSJFLUID) D EN^PSIVUDL(PSGOP,PSGORD,PSGLWD_U_PSGLWDN,PSGLRB)
- .D:PSGLWC2'=3 ^PSGLOI
- K DA,DIK S DA(1)=PSGTOL,DA=PSGLWD,DIK="^PS(53.41,"_PSGTOL_",1," D ^DIK
- I '$O(^PS(53.41,PSGTOL,1,0)) K DA,DIK S DA=PSGTOL,DIK="^PS(53.41," D ^DIK
- Q
- ;
- DEV2 ; device for new labels
- K IO("Q"),%ZIS,IOP S PSGION=ION,%ZIS("A")="Print on DEVICE: ",%ZIS="Q",%ZIS("B")=$P(PSJSYSL,"^",2) W ! D ^%ZIS K %ZIS I POP S IOP=PSGION D ^%ZIS K IOP S POP=1 W !,"No device selected. Option terminated." Q
- I $D(IO("Q")) S PSGTIR="ENNLP^PSGL0",ZTDESC="LABELS" K ZTSAVE D ENTSK^PSGTI W:$D(ZTSK) !,"Labels queued!" Q
- ;
- ENNLP ; new label print
- D NOW^%DTC N PSJFIRST,PSJFLUID
- S PSJFIRST=1,PSGDT=%,QT=2,QL=DUZ,PSJACNWP=1 U IO
- F PSGOP=0:0 S PSGOP=$O(^PS(53.41,2,1,DUZ,1,PSGOP)) Q:'PSGOP D ^PSGLPI F QS=1,2,3 F QO=0:0 S QO=$O(^PS(53.41,2,1,DUZ,1,PSGOP,1,QS,1,QO)) Q:'QO D
- . I PSJFIRST,$P($G(^PS(59.6,+$O(^PS(59.6,"B",+PSGLWD,0)),0)),U,18) D ENHEDER^PSGLPI S PSJFIRST=0
- . S PSGORD=QO_$E("ANV",QS) I QS=2 S X=^PS(53.1,+PSGORD,0),PSJFLUID=$P(X,U,4)="F"
- . I QS<3,'$G(PSJFLUID) D ^PSGLOI
- . I QS=3!$G(PSJFLUID) D EN^PSIVUDL(PSGOP,PSGORD,PSGLWD_U_PSGLWDN,PSGLRB)
- K DA,DIK S DA(1)=2,DA=DUZ,DIK="^PS(53.41,2,1," D ^DIK I '$O(^PS(53.41,2,1,0)) K DA,DIK S DA=2,DIK="^PS(53.41," D ^DIK
- Q
- NP ;
- R !!,"Enter an '^' to stop list, or press RETURN to continue. ",NP:DTIME W:'$T $C(7) S:'$T NP="^" W:NP'["^" *13,# Q
- ;
- DONE ;
- K NP,PSGOP,PSGION,QD,QS,SAVE,W,X1,X2,Z,ZTOUT D ^%ZISC
- Q
- ;
- ENKL ;
- K ^PS(53.41,QT,1,QL,1,PSGOP,1,QS,1,QO)
- ENKL1 Q:$O(^PS(53.41,QT,1,QL,1,PSGOP,1,QS,1,0)) K ^PS(53.41,QT,1,QL,1,PSGOP,1,QS) Q:$O(^PS(53.41,QT,1,QL,1,PSGOP,1,0)) K ^PS(53.41,QT,1,QL,1,PSGOP) Q:$O(^PS(53.41,QT,1,QL,1,0)) K ^PS(53.41,QT,1,QL)
- Q
- ;
- ENCU ; clean-up
- F QT=1,2 F QL=0:0 S QL=$O(^PS(53.41,QT,1,QL)) Q:'QL F PSGOP=0:0 S PSGOP=$O(^PS(53.41,QT,1,QL,1,PSGOP)) Q:'PSGOP F QS=1,2 D ENKL1
- K PSGOP,QL,QS,QT Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGL0 4720 printed Jan 18, 2025@03:02:35 Page 2
- PSGL0 ;BIR/CML3-ACTUAL LABEL PRINT ; 26 Jun 98 / 8:30 AM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**7**;16 DEC 97
- ENACL ;
- +1 WRITE !!,"There are unprinted new labels from AUTO ",$SELECT(PSGTOL=3:"REINSTATED",1:"DISCONTINUED")," orders."
- FOR
- WRITE !,"Do you want any of them now"
- SET %=1
- DO YN^DICN
- if %
- QUIT
- DO CHKM^PSGLH
- +2 if %<0
- QUIT
- IF %=1
- DO ENAC
- SET %=1
- QUIT
- +3 FOR
- WRITE !!,"Will you want these labels at a later date"
- SET %=1
- DO YN^DICN
- if %
- QUIT
- DO LM^PSGLH
- +4 if %'=2
- QUIT
- SET DIK="^PS(53.41,"
- SET DA=PSGTOL
- DO ^DIK
- SET %=2
- QUIT
- +5 ;
- ENAC ; select ward
- +1 WRITE !!,"Wards: "
- SET NP=""
- SET QQ=0
- FOR W=1:1
- SET QQ=$ORDER(^PS(53.41,PSGTOL,1,QQ))
- if 'QQ
- QUIT
- if '(W#20)
- DO NP
- if NP["^"
- QUIT
- WRITE !,$JUSTIFY(W,3),". ",$SELECT($DATA(^DIC(42,QQ,0)):$PIECE(^(0),"^"),1:QQ)
- SET W(W)=QQ
- +2 SET W=W-1
- IF 'W
- KILL ^PS(53.41,PSGTOL)
- WRITE !!?3,"Sorry, no labels were found after all. (The problem has been corrected.)",!
- QUIT
- +3 FOR
- WRITE !!,"Select 1 - ",W,": "
- READ X:DTIME
- if '$TEST
- WRITE $CHAR(7)
- if '$TEST
- SET X="^"
- if "^"[X
- QUIT
- DO SC
- if $DATA(X)
- QUIT
- +4 if "^"[X
- GOTO DONE
- SET PSGLWARD=PSGODDD
- FOR Q=1:1:PSGODDD
- FOR Q1=1:1
- SET Q2=$PIECE(PSGODDD(Q),",",Q1)
- if 'Q2
- QUIT
- SET PSGLWARD(Q)=$SELECT($DATA(PSGLWARD(Q)):PSGLWARD(Q)_",",1:"")_W(Q2)
- +5 KILL ZTSAVE
- SET PSGLRTN="ENACP^PSGL0"
- SET PSGLDESC="MAR AUTO LABELS"
- SET (ZTSAVE("PSGLWARD"),ZTSAVE("PSGLWARD("),ZTSAVE("PSGTOL"))=""
- DO DEV1
- IF 'POP
- IF '$DATA(IO("Q"))
- DO ENACP
- +6 GOTO DONE
- +7 ;
- ENNL ; new labels, other than auto discontinue
- +1 KILL ZTSAVE
- SET PSGLRTN="ENNLP^PSGL0"
- SET PSGLDESC="UD NEW LABEL REPRINT"
- DO DEV1
- if POP!$DATA(IO("Q"))
- GOTO DONE
- DO ENNLP
- +2 ;
- SC ; selection validation
- +1 IF X?1."?"
- WRITE !!," Select (1-",W,") the ward(s) you wish to print labels for. Enter an '^',",!,"or press the RETURN key, to quit now."
- KILL X
- QUIT
- +2 if '$DATA(W)
- QUIT
- +3 SET PSGLMT=W
- DO ^PSGON
- if '$DATA(X)
- WRITE $CHAR(7)," ??"
- QUIT
- +4 ;
- DEV1 ; device ask for auto discontinue or new labels
- +1 KILL IO("Q"),%ZIS,IOP
- 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 !,"No device selected. Option terminated."
- QUIT
- +2 DO EN2^PSGLBA
- SET POP=0
- IF $DATA(IO("Q"))
- SET PSGTIR=PSGLRTN
- SET ZTDESC=PSGLDESC
- SET (ZTSAVE("PSGLWARD"),ZTSAVE("PSGLWARD("),ZTSAVE("PSGTOL"))=""
- WRITE !
- DO ENTSK^PSGTI
- KILL PSGLDESC,PSGLRTN
- if $DATA(ZTSK)
- WRITE !?3,"Labels queued!"
- +3 QUIT
- +4 ;
- ENACP ; auto label print
- +1 DO NOW^%DTC
- SET PSGDT=%
- USE IO
- +2 FOR PSGLWC=1:1:PSGLWARD
- FOR PSGLWC1=1:1:$LENGTH(PSGLWARD(PSGLWC),",")
- SET PSGLWD=$PIECE(PSGLWARD(PSGLWC),",",PSGLWC1)
- SET PSGLWDN=$SELECT($DATA(^DIC(42,PSGLWD,0)):$PIECE(^(0),"^"),1:"zz")
- FOR PSGOP=0:0
- SET PSGOP=$ORDER(^PS(53.41,PSGTOL,1,PSGLWD,1,PSGOP))
- if 'PSGOP
- QUIT
- DO AC
- +3 QUIT
- AC ;
- +1 NEW PSJFIRST,VAINDT
- SET PSJFIRST=1
- +2 FOR PSGLWC2=1,2,3
- FOR PSGLWC3=0:0
- SET PSGLWC3=$ORDER(^PS(53.41,PSGTOL,1,PSGLWD,1,PSGOP,1,PSGLWC2,1,PSGLWC3))
- if 'PSGLWC3
- QUIT
- SET PSGORD=PSGLWC3_$EXTRACT("ANV",PSGLWC2)
- Begin DoDot:1
- +3 if PSGTOL'=2
- SET VAINDT=$EXTRACT($PIECE($GET(^PS(53.41,PSGTOL,1,PSGLWD,1,PSGOP,1,PSGLWC2,1,PSGLWC3,0)),U,3),1,12)
- DO ^PSGLPI
- +4 IF PSJFIRST
- DO ENHEDER^PSGLPI
- SET PSJFIRST=0
- +5 IF PSGLWC2=2
- IF ($PIECE($GET(^PS(53.1,+PSGORD,0)),U,9)="P")
- SET PSGORD=+PSGORD_"P"
- NEW PSJFLUID
- if $PIECE(^(0),U,4)="F"
- SET PSJFLUID=1
- +6 IF PSGLWC2=3!$GET(PSJFLUID)
- DO EN^PSIVUDL(PSGOP,PSGORD,PSGLWD_U_PSGLWDN,PSGLRB)
- +7 if PSGLWC2'=3
- DO ^PSGLOI
- End DoDot:1
- +8 KILL DA,DIK
- SET DA(1)=PSGTOL
- SET DA=PSGLWD
- SET DIK="^PS(53.41,"_PSGTOL_",1,"
- DO ^DIK
- +9 IF '$ORDER(^PS(53.41,PSGTOL,1,0))
- KILL DA,DIK
- SET DA=PSGTOL
- SET DIK="^PS(53.41,"
- DO ^DIK
- +10 QUIT
- +11 ;
- DEV2 ; device for new labels
- +1 KILL IO("Q"),%ZIS,IOP
- SET PSGION=ION
- SET %ZIS("A")="Print on DEVICE: "
- SET %ZIS="Q"
- SET %ZIS("B")=$PIECE(PSJSYSL,"^",2)
- WRITE !
- DO ^%ZIS
- KILL %ZIS
- IF POP
- SET IOP=PSGION
- DO ^%ZIS
- KILL IOP
- SET POP=1
- WRITE !,"No device selected. Option terminated."
- QUIT
- +2 IF $DATA(IO("Q"))
- SET PSGTIR="ENNLP^PSGL0"
- SET ZTDESC="LABELS"
- KILL ZTSAVE
- DO ENTSK^PSGTI
- if $DATA(ZTSK)
- WRITE !,"Labels queued!"
- QUIT
- +3 ;
- ENNLP ; new label print
- +1 DO NOW^%DTC
- NEW PSJFIRST,PSJFLUID
- +2 SET PSJFIRST=1
- SET PSGDT=%
- SET QT=2
- SET QL=DUZ
- SET PSJACNWP=1
- USE IO
- +3 FOR PSGOP=0:0
- SET PSGOP=$ORDER(^PS(53.41,2,1,DUZ,1,PSGOP))
- if 'PSGOP
- QUIT
- DO ^PSGLPI
- FOR QS=1,2,3
- FOR QO=0:0
- SET QO=$ORDER(^PS(53.41,2,1,DUZ,1,PSGOP,1,QS,1,QO))
- if 'QO
- QUIT
- Begin DoDot:1
- +4 IF PSJFIRST
- IF $PIECE($GET(^PS(59.6,+$ORDER(^PS(59.6,"B",+PSGLWD,0)),0)),U,18)
- DO ENHEDER^PSGLPI
- SET PSJFIRST=0
- +5 SET PSGORD=QO_$EXTRACT("ANV",QS)
- IF QS=2
- SET X=^PS(53.1,+PSGORD,0)
- SET PSJFLUID=$PIECE(X,U,4)="F"
- +6 IF QS<3
- IF '$GET(PSJFLUID)
- DO ^PSGLOI
- +7 IF QS=3!$GET(PSJFLUID)
- DO EN^PSIVUDL(PSGOP,PSGORD,PSGLWD_U_PSGLWDN,PSGLRB)
- End DoDot:1
- +8 KILL DA,DIK
- SET DA(1)=2
- SET DA=DUZ
- SET DIK="^PS(53.41,2,1,"
- DO ^DIK
- IF '$ORDER(^PS(53.41,2,1,0))
- KILL DA,DIK
- SET DA=2
- SET DIK="^PS(53.41,"
- DO ^DIK
- +9 QUIT
- NP ;
- +1 READ !!,"Enter an '^' to stop list, or press RETURN to continue. ",NP:DTIME
- if '$TEST
- WRITE $CHAR(7)
- if '$TEST
- SET NP="^"
- if NP'["^"
- WRITE *13,#
- QUIT
- +2 ;
- DONE ;
- +1 KILL NP,PSGOP,PSGION,QD,QS,SAVE,W,X1,X2,Z,ZTOUT
- DO ^%ZISC
- +2 QUIT
- +3 ;
- ENKL ;
- +1 KILL ^PS(53.41,QT,1,QL,1,PSGOP,1,QS,1,QO)
- ENKL1 if $ORDER(^PS(53.41,QT,1,QL,1,PSGOP,1,QS,1,0))
- QUIT
- KILL ^PS(53.41,QT,1,QL,1,PSGOP,1,QS)
- if $ORDER(^PS(53.41,QT,1,QL,1,PSGOP,1,0))
- QUIT
- KILL ^PS(53.41,QT,1,QL,1,PSGOP)
- if $ORDER(^PS(53.41,QT,1,QL,1,0))
- QUIT
- KILL ^PS(53.41,QT,1,QL)
- +1 QUIT
- +2 ;
- ENCU ; clean-up
- +1 FOR QT=1,2
- FOR QL=0:0
- SET QL=$ORDER(^PS(53.41,QT,1,QL))
- if 'QL
- QUIT
- FOR PSGOP=0:0
- SET PSGOP=$ORDER(^PS(53.41,QT,1,QL,1,PSGOP))
- if 'PSGOP
- QUIT
- FOR QS=1,2
- DO ENKL1
- +2 KILL PSGOP,QL,QS,QT
- QUIT