- PSIVSUS1 ;BIR/RGY-REPRINT LABEL FROM SUSPENSE ;24 JAN 94 / 11:37 AM
- ;;5.0;INPATIENT MEDICATIONS;**58,407**;16 DEC 97;Build 26
- ;
- ; Reference to ^PS(55 is supported by DBIA 2191.
- ;
- D ^PSIVXU I $D(XQUIT) K XQUIT Q
- Q:$G(DONE) ;P407
- BEG S Y=1,BAT="@",PSIVRPNT=1 F I=1:1 S BAT=$O(^PS(55,"PSIVSUS",PSIVSN,BAT)) Q:BAT="" W !?5,I,") Labels printed on: " S Y=$E(BAT,2,999) X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2) S Y=BAT
- I Y W !!,"*** There are no labels to reprint ! ***" G Q
- ASK S X="Reprint batch #^"_(I-1)_"^^^QUX=+QUX" D ENQ^PSIV G:"^"[X Q I X["?" S HELP="RNTBAT" D ^PSIVHLP1 G ASK
- S PSIVDT=+X\1,X="A" F Y=1:1 S X=$O(^PS(55,"PSIVSUS",PSIVSN,X)) Q:X=""!(Y=PSIVDT)
- I X="" W $C(7)," ???" G ASK
- OV S PSIVDT=X S Y=$E(X,2,999) X ^DD("DD") W " Labels printed on ",$P(Y,"@")," ",$P(Y,"@",2)
- I PSIVPL'=ION S ZTIO=PSIVPL,ZTDESC="REPRINT LABELS FROM SUSPENSE (IV)",ZTRTN="DQLBL^PSIVSUS1" D QSET G Q
- DQLBL F DFN=0:0 S DFN=$O(^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN)) Q:'DFN D ENIV^PSJAC F ON=0:0 S ON=$O(^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON)) Q:'ON F SDT=0:0 S SDT=$O(^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT)) Q:'SDT D LA
- Q K BAT,PSIVDOSE,PSIVDT,PSIVNOL,PSIVRPNT,SDT,Z
- Q1 D ENIVKV^PSGSETU S:$D(ZTQUEUED) ZTREQ="@"
- Q
- LA Q:"PDH"[$P($G(^PS(55,DFN,"IV",ON,0)),"^",17)
- ;S PSIVNOL=^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT),PSIVDOSE=$P(PSIVNOL,"^",2),PSIVCT=1,ACTION=1,TRACK=3,P16=$P(PSIVNOL,"^",3),PSIVNOL=+PSIVNOL,P(4)=$P(^PS(55,DFN,"IV",ON,0),"^",4) D ^PSIVLTR D ^PSIVHYPL:P(4)="H",^PSIVLABL:"APSC"[P(4) Q
- S PSIVNOL=^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT),PSIVDOSE=$P(PSIVNOL,"^",2),PSIVCT=1,ACTION=1,TRACK=3,P16=$P(PSIVNOL,"^",3),PSIVNOL=+PSIVNOL,P(4)=$P(^PS(55,DFN,"IV",ON,0),"^",4)
- D ^PSIVLTR
- S PSIVWMFL=1
- NEW PSJID,PSIVOID,PSIVID,X,XX
- F PSJID=0:0 S PSJID=$O(^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT,PSJID)) Q:'PSJID D REPRT^PSIVLBL1
- ;
- ;Kill old ID and set newly reprinted ID.
- ;
- F X=0:0 S X=$O(PSIVOID(X)) Q:'X D
- . K ^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT,X)
- F X=0:0 S X=$O(PSIVID(X)) Q:'X D
- . S ^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT,X)=""
- K PSIVWMFL,PSIVOID,PSIVID
- Q
- ENT ;Will print man. list for suspense
- D ^PSIVXU I $D(PSIVXU) K PSIVXU Q
- Q:$G(DONE) ;P407
- I PSIVPR'=ION K ZTDTH S ZTIO=PSIVPR,ZTDESC="PRINT MANUFACTURING LIST FOR SUSPENSE (IV)",ZTRTN="DQENT^PSIVSUS1" D QSET G QENT
- DQENT K ^PS(55,"PSIVSUSM",PSIVSN,$J),PSIVOD,PSIVCD,PSIVMT S PSIVGL1="PSIVSUSM",PSIVGL2=$J
- F DFN=0:0 S DFN=$O(^PS(55,"PSIVSUS",PSIVSN,DFN)) Q:'DFN D ENIV^PSJAC,RGY
- D ENT^PSIVMAN1
- QENT W:'$D(PSIVPR)&($Y) @IOF K ^PS(55,"PSIVSUSM",PSIVSN,$J),D,DA,DFN,I,JJ,JJ1,ON,P,PSIVGL1,PSIVGL2,PSIVTTM,SDT,TOTAL,VAERR,X,Y,Z,Z1,Z2 D Q1
- Q
- RGY F ON=0:0 S ON=$O(^PS(55,"PSIVSUS",PSIVSN,DFN,ON)) Q:'ON D SETP I "EOPHD"'[P(17) F SDT=0:0 S SDT=$O(^PS(55,"PSIVSUS",PSIVSN,DFN,ON,SDT)) Q:'SDT S PSIVTTM=+^(SDT) D ENS^PSIVMAN
- Q
- SETP S Y=$G(^PS(55,DFN,"IV",ON,0)) F X=1:1:23 S P(X)=$P(Y,"^",X)
- Q
- ;
- QSET ; Set up for queueing.
- F X="PSIVSN","PSIVDT","PSIVSITE","PSJSYSW0","PSJSYSP0","PSJSYSU" S:$D(@X) ZTSAVE(X)=""
- D ^%ZTLOAD W:$D(ZTSK) !,"Queued."
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVSUS1 3096 printed Feb 18, 2025@23:31:32 Page 2
- PSIVSUS1 ;BIR/RGY-REPRINT LABEL FROM SUSPENSE ;24 JAN 94 / 11:37 AM
- +1 ;;5.0;INPATIENT MEDICATIONS;**58,407**;16 DEC 97;Build 26
- +2 ;
- +3 ; Reference to ^PS(55 is supported by DBIA 2191.
- +4 ;
- +5 DO ^PSIVXU
- IF $DATA(XQUIT)
- KILL XQUIT
- QUIT
- +6 ;P407
- if $GET(DONE)
- QUIT
- BEG SET Y=1
- SET BAT="@"
- SET PSIVRPNT=1
- FOR I=1:1
- SET BAT=$ORDER(^PS(55,"PSIVSUS",PSIVSN,BAT))
- if BAT=""
- QUIT
- WRITE !?5,I,") Labels printed on: "
- SET Y=$EXTRACT(BAT,2,999)
- XECUTE ^DD("DD")
- WRITE $PIECE(Y,"@")," ",$PIECE(Y,"@",2)
- SET Y=BAT
- +1 IF Y
- WRITE !!,"*** There are no labels to reprint ! ***"
- GOTO Q
- ASK SET X="Reprint batch #^"_(I-1)_"^^^QUX=+QUX"
- DO ENQ^PSIV
- if "^"[X
- GOTO Q
- IF X["?"
- SET HELP="RNTBAT"
- DO ^PSIVHLP1
- GOTO ASK
- +1 SET PSIVDT=+X\1
- SET X="A"
- FOR Y=1:1
- SET X=$ORDER(^PS(55,"PSIVSUS",PSIVSN,X))
- if X=""!(Y=PSIVDT)
- QUIT
- +2 IF X=""
- WRITE $CHAR(7)," ???"
- GOTO ASK
- OV SET PSIVDT=X
- SET Y=$EXTRACT(X,2,999)
- XECUTE ^DD("DD")
- WRITE " Labels printed on ",$PIECE(Y,"@")," ",$PIECE(Y,"@",2)
- +1 IF PSIVPL'=ION
- SET ZTIO=PSIVPL
- SET ZTDESC="REPRINT LABELS FROM SUSPENSE (IV)"
- SET ZTRTN="DQLBL^PSIVSUS1"
- DO QSET
- GOTO Q
- DQLBL FOR DFN=0:0
- SET DFN=$ORDER(^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN))
- if 'DFN
- QUIT
- DO ENIV^PSJAC
- FOR ON=0:0
- SET ON=$ORDER(^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON))
- if 'ON
- QUIT
- FOR SDT=0:0
- SET SDT=$ORDER(^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT))
- if 'SDT
- QUIT
- DO LA
- Q KILL BAT,PSIVDOSE,PSIVDT,PSIVNOL,PSIVRPNT,SDT,Z
- Q1 DO ENIVKV^PSGSETU
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +1 QUIT
- LA if "PDH"[$PIECE($GET(^PS(55,DFN,"IV",ON,0)),"^",17)
- QUIT
- +1 ;S PSIVNOL=^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT),PSIVDOSE=$P(PSIVNOL,"^",2),PSIVCT=1,ACTION=1,TRACK=3,P16=$P(PSIVNOL,"^",3),PSIVNOL=+PSIVNOL,P(4)=$P(^PS(55,DFN,"IV",ON,0),"^",4) D ^PSIVLTR D ^PSIVHYPL:P(4)="H",^PSIVLABL:"APSC"[P(4) Q
- +2 SET PSIVNOL=^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT)
- SET PSIVDOSE=$PIECE(PSIVNOL,"^",2)
- SET PSIVCT=1
- SET ACTION=1
- SET TRACK=3
- SET P16=$PIECE(PSIVNOL,"^",3)
- SET PSIVNOL=+PSIVNOL
- SET P(4)=$PIECE(^PS(55,DFN,"IV",ON,0),"^",4)
- +3 DO ^PSIVLTR
- +4 SET PSIVWMFL=1
- +5 NEW PSJID,PSIVOID,PSIVID,X,XX
- +6 FOR PSJID=0:0
- SET PSJID=$ORDER(^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT,PSJID))
- if 'PSJID
- QUIT
- DO REPRT^PSIVLBL1
- +7 ;
- +8 ;Kill old ID and set newly reprinted ID.
- +9 ;
- +10 FOR X=0:0
- SET X=$ORDER(PSIVOID(X))
- if 'X
- QUIT
- Begin DoDot:1
- +11 KILL ^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT,X)
- End DoDot:1
- +12 FOR X=0:0
- SET X=$ORDER(PSIVID(X))
- if 'X
- QUIT
- Begin DoDot:1
- +13 SET ^PS(55,"PSIVSUS",PSIVSN,PSIVDT,DFN,ON,SDT,X)=""
- End DoDot:1
- +14 KILL PSIVWMFL,PSIVOID,PSIVID
- +15 QUIT
- ENT ;Will print man. list for suspense
- +1 DO ^PSIVXU
- IF $DATA(PSIVXU)
- KILL PSIVXU
- QUIT
- +2 ;P407
- if $GET(DONE)
- QUIT
- +3 IF PSIVPR'=ION
- KILL ZTDTH
- SET ZTIO=PSIVPR
- SET ZTDESC="PRINT MANUFACTURING LIST FOR SUSPENSE (IV)"
- SET ZTRTN="DQENT^PSIVSUS1"
- DO QSET
- GOTO QENT
- DQENT KILL ^PS(55,"PSIVSUSM",PSIVSN,$JOB),PSIVOD,PSIVCD,PSIVMT
- SET PSIVGL1="PSIVSUSM"
- SET PSIVGL2=$JOB
- +1 FOR DFN=0:0
- SET DFN=$ORDER(^PS(55,"PSIVSUS",PSIVSN,DFN))
- if 'DFN
- QUIT
- DO ENIV^PSJAC
- DO RGY
- +2 DO ENT^PSIVMAN1
- QENT if '$DATA(PSIVPR)&($Y)
- WRITE @IOF
- KILL ^PS(55,"PSIVSUSM",PSIVSN,$JOB),D,DA,DFN,I,JJ,JJ1,ON,P,PSIVGL1,PSIVGL2,PSIVTTM,SDT,TOTAL,VAERR,X,Y,Z,Z1,Z2
- DO Q1
- +1 QUIT
- RGY FOR ON=0:0
- SET ON=$ORDER(^PS(55,"PSIVSUS",PSIVSN,DFN,ON))
- if 'ON
- QUIT
- DO SETP
- IF "EOPHD"'[P(17)
- FOR SDT=0:0
- SET SDT=$ORDER(^PS(55,"PSIVSUS",PSIVSN,DFN,ON,SDT))
- if 'SDT
- QUIT
- SET PSIVTTM=+^(SDT)
- DO ENS^PSIVMAN
- +1 QUIT
- SETP SET Y=$GET(^PS(55,DFN,"IV",ON,0))
- FOR X=1:1:23
- SET P(X)=$PIECE(Y,"^",X)
- +1 QUIT
- +2 ;
- QSET ; Set up for queueing.
- +1 FOR X="PSIVSN","PSIVDT","PSIVSITE","PSJSYSW0","PSJSYSP0","PSJSYSU"
- if $DATA(@X)
- SET ZTSAVE(X)=""
- +2 DO ^%ZTLOAD
- if $DATA(ZTSK)
- WRITE !,"Queued."
