- PSIVRP ;BIR/MLM-REPRINT IV LABELS FROM WARD OR MANUFACTURING LIST ;12 JUL 96 / 10:45 AM
- ;;5.0; INPATIENT MEDICATIONS ;**38,58**;16 DEC 97
- ;
- ; Reference to ^PS(55 is supported by DBIA 2191
- ; Reference to ^PS(52.6 is supported by DBIA 1231
- ; Reference to ^PS(52.7 is supported by DBIA 2173
- ; Reference to ^DIC(42 is supported by DBIA# 10039
- ;
- D ^PSIVXU Q:$D(XQUIT) I '$D(^PS(55,"PSIVWL",PSIVSN)) W $C(7),!!,"THIS OPTION MAY BE USED ONLY AFTER THE WARD LIST HAS BEEN RUN",!! G QUIT^PSIVRP1
- K DIR S DIR(0)="DOA^NE",DIR("A")="Reprint labels for DATE: ",DIR("B")="TODAY",DIR("??")="^S HELP=""REPRINT"" D ^PSIVHLP2" D ^DIR K DIR G:Y<1 QUIT^PSIVRP1 K PS D GTMES^PSIVRP1
- I '$D(PS) W $C(7),!!,"The Ward list & Scheduled Labels options MUST be run for the chosen date",!,"before you may use this option!!",!! K DIR S DIR(0)="E" D ^DIR K DIR G QUIT^PSIVRP1
- SELMAN ;
- K PSM S PSCT=0 F I=0:0 S I=$O(^PS(59.5,PSIVSN,2,I)) Q:'I S PSIVDTS=^(I,0),PSIVDT=Y_"."_$P(PSIVDTS,"^")/1,PSIVDT=$P(PSIVDTS,"^",2)_PSIVDT S:$D(PS(PSIVDT)) PSM(I)=PSIVDTS,PS(I)=PSIVDT,PSCT=PSCT+1
- W !!,?5,"The manufacturing times which scheduled labels have been run for are: " D P0^PSIVWL1 G:'X QUIT^PSIVRP1 K PSR F J=1:1:$L(X,",") S Y=$P(X,",",J) S:$D(PS(+Y)) PSR(PS(Y))=""
- FNDLBLS ;
- K PS,DIC S J="LAST",DIC=55,DIC("A")="Select PATIENT on LAST usable label: ",DIC(0)="AEMQ" D GTRANGE G:Y<0 QUIT^PSIVRP1 F X=1:1:$S(LIST="M":7,1:6) S LAST($P(STR,"^",X))=@$P(STR,"^",X)
- S J="NEXT",DIC("A")="Select PATIENT on NEXT usable label or RETURN to print to end: " D GTRANGE K DIC G:X="^" QUIT^PSIVRP1 S:'DFN LIST=LAST("LIST") F X=1:1:$S(LIST="M":7,1:6) S NEXT($P(STR,"^",X))=@$P(STR,"^",X)
- G:NEXT("DFN")="" SKIP F X=2:1:$L(STR,"^") Q:NEXT($P(STR,"^",X))'=LAST($P(STR,"^",X))
- I NEXT($P(STR,"^",X))']LAST($P(STR,"^",X)) W $C(7),!!,"NEXT LABEL MUST FOLLOW LAST LABEL",!! G FNDLBLS
- SKIP ;
- I PSIVPL=ION D DEQ^PSIVRP1 G QUIT^PSIVRP1
- QUE ;
- K ZTDTH,ZTSAVE S ZTIO=PSIVPL,ZTRTN="DEQ^PSIVRP1",ZTDESC="Reprint I.V. Labels" F X="LAST(","NEXT(","PSR(","PSIVSN","PSIVSITE","PSJSYSW0","PSJSYSU","PSJSYSP0","STR" S ZTSAVE(X)=""
- D ^%ZTLOAD W:$D(ZTSK) !,"Queued." D QUIT^PSIVRP1
- Q
- GTRANGE ;
- K NEXT S (LIST,PSIVDT,PSIVT,X1,X2,DFN,ON,WRD)=""
- ;* D ^DIC Q:'$T!(Y<0) S DFN=+Y D ENIV^PSJAC D GTORDR S (PRO,ON)="" I '$D(PS) W $C(7),!!,VADM(1)," has no IV orders on the Ward List for the date &",!,"manufacturing times chosen",! G GTRANGE
- D ^DIC Q:(Y<0) S DFN=+Y D ENIV^PSJAC D GTORDR S (PRO,ON)="" I '$D(PS) W $C(7),!!,VADM(1)," has no IV orders on the Ward List for the date &",!,"manufacturing times chosen",! G GTRANGE
- ORDER ;
- S:'PRO ON="" S P="Select order number of the "_J_" usable label: " W !!,$E(P,1,44),$S(ON:" or RETURN to continue: ",1:": ") R X:DTIME
- G:'$T!(X="^") GTRANGE G:$D(PS("A",+X)) ORDER1 I ON,(X="") D PRO G ORDER
- I 'PRO,(X["??") D PRO G ORDER
- G:X="" GTRANGE W $C(7),!!,"Enter the ",$E(P,8,44)," for ",VADM(1),",",! W:'PRO """??"" to see a profile of all orders on the ward list for this patient,",! W " or ""^"" to exit",!! G ORDER
- ORDER1 ;
- W !! S ON=+X,Y=^PS(55,DFN,"IV",ON,0),PSIVT=$S($P(Y,"^",4)'="":$P(Y,"^",4),1:0),PSIVDT=$O(PSR(PSIVT)),WRD=$S($D(^DIC(42,+$P(Y,"^",22),0)):$P(^(0),"^",1),1:"Outpatient IV")
- S LIST=$S($D(^PS(55,"PSIVWLM",PSIVSN,PSIVDT)):"M",1:"W")
- S STR=$S(LIST="M":"LIST^PSIVT^PSIVDT^X1^X2^DFN^ON",1:"LIST^PSIVT^WRD^PSIVDT^DFN^ON") Q:LIST="W" S FILE="AD",X1=0 D BU S X1=X,FILE="SOL",X2=0 D BU S X2=X G:X1=0!(X2=0) QUIT^PSIVRP1 I PSIVT="A" S XT=X1,X1=X2,X2=XT
- Q
- BU ;
- S D1=0,D1=$O(^PS(55,DFN,"IV",ON,FILE,D1))
- I $D(^PS(55,DFN,"IV",ON,FILE,+D1,0)) S PSIVDRG=$P(^(0),"^",1,2),NF=$S(FILE="AD":"zz6",1:"zz7"),X=$S($D(^PS("52."_$E(NF,3),+PSIVDRG,0)):$E($P(^(0),"^",1),1,10),1:NF) S X=X_"^"_$P(PSIVDRG,"^",2)_"^"_$E(NF,3)_";"_+PSIVDRG
- Q
- GTORDR ;
- K PS S WRD="" F X=0:0 S WRD=$O(^PS(55,"PSIVWL",PSIVSN,WRD)) Q:WRD="" S PSIVDT="" F X=0:0 S PSIVDT=$O(PSR(PSIVDT)) Q:PSIVDT="" F ON=0:0 S ON=$O(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVDT,DFN,ON)) Q:ON="" S PS("A",ON)=""
- Q
- PRO ;
- ;N PG S (PG,PSJLN,PRO)=1,PSIVST="A" D HDL^PSIVPRO F X1=1:1 S ON=$O(PS("A",ON)) Q:ON=""!($Y+5>IOSL) S ON55=ON D GT55^PSIVORFB S ON=9999999999-ON,PSIVX1=ON55 D ENPL^PSIVPRO S ON=9999999999-ON
- D HDR^PSJLMHED(DFN)
- N PG,PSIVX2 S PSIVX2=0,(PG,PSJLN,PRO)=1,PSIVST="A"
- D HDL^PSIVPRO F X1=1:1 S ON=$O(PS("A",ON)) Q:ON="" S ON55=ON D GT55^PSIVORFB S ON=9999999999-ON,PSIVX1=ON55 D ENPL^PSIVPRO S ON=9999999999-ON
- NEW XX F XX=0:0 S XX=$O(^TMP("PSJPRO",$J,XX)) Q:'XX W !,^(XX,0)
- S:'ON PRO=""
- K ^TMP("PSJPRO",$J)
- Q
- SETP ;
- S Y=^PS(55,DFN,"IV",ON,0) F X=1:1:23 S P(X)=$P(Y,"^",X)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVRP 4607 printed Jan 18, 2025@03:06:13 Page 2
- PSIVRP ;BIR/MLM-REPRINT IV LABELS FROM WARD OR MANUFACTURING LIST ;12 JUL 96 / 10:45 AM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**38,58**;16 DEC 97
- +2 ;
- +3 ; Reference to ^PS(55 is supported by DBIA 2191
- +4 ; Reference to ^PS(52.6 is supported by DBIA 1231
- +5 ; Reference to ^PS(52.7 is supported by DBIA 2173
- +6 ; Reference to ^DIC(42 is supported by DBIA# 10039
- +7 ;
- +8 DO ^PSIVXU
- if $DATA(XQUIT)
- QUIT
- IF '$DATA(^PS(55,"PSIVWL",PSIVSN))
- WRITE $CHAR(7),!!,"THIS OPTION MAY BE USED ONLY AFTER THE WARD LIST HAS BEEN RUN",!!
- GOTO QUIT^PSIVRP1
- +9 KILL DIR
- SET DIR(0)="DOA^NE"
- SET DIR("A")="Reprint labels for DATE: "
- SET DIR("B")="TODAY"
- SET DIR("??")="^S HELP=""REPRINT"" D ^PSIVHLP2"
- DO ^DIR
- KILL DIR
- if Y<1
- GOTO QUIT^PSIVRP1
- KILL PS
- DO GTMES^PSIVRP1
- +10 IF '$DATA(PS)
- WRITE $CHAR(7),!!,"The Ward list & Scheduled Labels options MUST be run for the chosen date",!,"before you may use this option!!",!!
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- GOTO QUIT^PSIVRP1
- SELMAN ;
- +1 KILL PSM
- SET PSCT=0
- FOR I=0:0
- SET I=$ORDER(^PS(59.5,PSIVSN,2,I))
- if 'I
- QUIT
- SET PSIVDTS=^(I,0)
- SET PSIVDT=Y_"."_$PIECE(PSIVDTS,"^")/1
- SET PSIVDT=$PIECE(PSIVDTS,"^",2)_PSIVDT
- if $DATA(PS(PSIVDT))
- SET PSM(I)=PSIVDTS
- SET PS(I)=PSIVDT
- SET PSCT=PSCT+1
- +2 WRITE !!,?5,"The manufacturing times which scheduled labels have been run for are: "
- DO P0^PSIVWL1
- if 'X
- GOTO QUIT^PSIVRP1
- KILL PSR
- FOR J=1:1:$LENGTH(X,",")
- SET Y=$PIECE(X,",",J)
- if $DATA(PS(+Y))
- SET PSR(PS(Y))=""
- FNDLBLS ;
- +1 KILL PS,DIC
- SET J="LAST"
- SET DIC=55
- SET DIC("A")="Select PATIENT on LAST usable label: "
- SET DIC(0)="AEMQ"
- DO GTRANGE
- if Y<0
- GOTO QUIT^PSIVRP1
- FOR X=1:1:$SELECT(LIST="M":7,1:6)
- SET LAST($PIECE(STR,"^",X))=@$PIECE(STR,"^",X)
- +2 SET J="NEXT"
- SET DIC("A")="Select PATIENT on NEXT usable label or RETURN to print to end: "
- DO GTRANGE
- KILL DIC
- if X="^"
- GOTO QUIT^PSIVRP1
- if 'DFN
- SET LIST=LAST("LIST")
- FOR X=1:1:$SELECT(LIST="M":7,1:6)
- SET NEXT($PIECE(STR,"^",X))=@$PIECE(STR,"^",X)
- +3 if NEXT("DFN")=""
- GOTO SKIP
- FOR X=2:1:$LENGTH(STR,"^")
- if NEXT($PIECE(STR,"^",X))'=LAST($PIECE(STR,"^",X))
- QUIT
- +4 IF NEXT($PIECE(STR,"^",X))']LAST($PIECE(STR,"^",X))
- WRITE $CHAR(7),!!,"NEXT LABEL MUST FOLLOW LAST LABEL",!!
- GOTO FNDLBLS
- SKIP ;
- +1 IF PSIVPL=ION
- DO DEQ^PSIVRP1
- GOTO QUIT^PSIVRP1
- QUE ;
- +1 KILL ZTDTH,ZTSAVE
- SET ZTIO=PSIVPL
- SET ZTRTN="DEQ^PSIVRP1"
- SET ZTDESC="Reprint I.V. Labels"
- FOR X="LAST(","NEXT(","PSR(","PSIVSN","PSIVSITE","PSJSYSW0","PSJSYSU","PSJSYSP0","STR"
- SET ZTSAVE(X)=""
- +2 DO ^%ZTLOAD
- if $DATA(ZTSK)
- WRITE !,"Queued."
- DO QUIT^PSIVRP1
- +3 QUIT
- GTRANGE ;
- +1 KILL NEXT
- SET (LIST,PSIVDT,PSIVT,X1,X2,DFN,ON,WRD)=""
- +2 ;* D ^DIC Q:'$T!(Y<0) S DFN=+Y D ENIV^PSJAC D GTORDR S (PRO,ON)="" I '$D(PS) W $C(7),!!,VADM(1)," has no IV orders on the Ward List for the date &",!,"manufacturing times chosen",! G GTRANGE
- +3 DO ^DIC
- if (Y<0)
- QUIT
- SET DFN=+Y
- DO ENIV^PSJAC
- DO GTORDR
- SET (PRO,ON)=""
- IF '$DATA(PS)
- WRITE $CHAR(7),!!,VADM(1)," has no IV orders on the Ward List for the date &",!,"manufacturing times chosen",!
- GOTO GTRANGE
- ORDER ;
- +1 if 'PRO
- SET ON=""
- SET P="Select order number of the "_J_" usable label: "
- WRITE !!,$EXTRACT(P,1,44),$SELECT(ON:" or RETURN to continue: ",1:": ")
- READ X:DTIME
- +2 if '$TEST!(X="^")
- GOTO GTRANGE
- if $DATA(PS("A",+X))
- GOTO ORDER1
- IF ON
- IF (X="")
- DO PRO
- GOTO ORDER
- +3 IF 'PRO
- IF (X["??")
- DO PRO
- GOTO ORDER
- +4 if X=""
- GOTO GTRANGE
- WRITE $CHAR(7),!!,"Enter the ",$EXTRACT(P,8,44)," for ",VADM(1),",",!
- if 'PRO
- WRITE """??"" to see a profile of all orders on the ward list for this patient,",!
- WRITE " or ""^"" to exit",!!
- GOTO ORDER
- ORDER1 ;
- +1 WRITE !!
- SET ON=+X
- SET Y=^PS(55,DFN,"IV",ON,0)
- SET PSIVT=$SELECT($PIECE(Y,"^",4)'="":$PIECE(Y,"^",4),1:0)
- SET PSIVDT=$ORDER(PSR(PSIVT))
- SET WRD=$SELECT($DATA(^DIC(42,+$PIECE(Y,"^",22),0)):$PIECE(^(0),"^",1),1:"Outpatient IV")
- +2 SET LIST=$SELECT($DATA(^PS(55,"PSIVWLM",PSIVSN,PSIVDT)):"M",1:"W")
- +3 SET STR=$SELECT(LIST="M":"LIST^PSIVT^PSIVDT^X1^X2^DFN^ON",1:"LIST^PSIVT^WRD^PSIVDT^DFN^ON")
- if LIST="W"
- QUIT
- SET FILE="AD"
- SET X1=0
- DO BU
- SET X1=X
- SET FILE="SOL"
- SET X2=0
- DO BU
- SET X2=X
- if X1=0!(X2=0)
- GOTO QUIT^PSIVRP1
- IF PSIVT="A"
- SET XT=X1
- SET X1=X2
- SET X2=XT
- +4 QUIT
- BU ;
- +1 SET D1=0
- SET D1=$ORDER(^PS(55,DFN,"IV",ON,FILE,D1))
- +2 IF $DATA(^PS(55,DFN,"IV",ON,FILE,+D1,0))
- SET PSIVDRG=$PIECE(^(0),"^",1,2)
- SET NF=$SELECT(FILE="AD":"zz6",1:"zz7")
- SET X=$SELECT($DATA(^PS("52."_$EXTRACT(NF,3),+PSIVDRG,0)):$EXTRACT($PIECE(^(0),"^",1),1,10),1:NF)
- SET X=X_"^"_$PIECE(PSIVDRG,"^",2)_"^"_$EXTRACT(NF,3)_";"_+PSIVDRG
- +3 QUIT
- GTORDR ;
- +1 KILL PS
- SET WRD=""
- FOR X=0:0
- SET WRD=$ORDER(^PS(55,"PSIVWL",PSIVSN,WRD))
- if WRD=""
- QUIT
- SET PSIVDT=""
- FOR X=0:0
- SET PSIVDT=$ORDER(PSR(PSIVDT))
- if PSIVDT=""
- QUIT
- FOR ON=0:0
- SET ON=$ORDER(^PS(55,"PSIVWL",PSIVSN,WRD,PSIVDT,DFN,ON))
- if ON=""
- QUIT
- SET PS("A",ON)=""
- +2 QUIT
- PRO ;
- +1 ;N PG S (PG,PSJLN,PRO)=1,PSIVST="A" D HDL^PSIVPRO F X1=1:1 S ON=$O(PS("A",ON)) Q:ON=""!($Y+5>IOSL) S ON55=ON D GT55^PSIVORFB S ON=9999999999-ON,PSIVX1=ON55 D ENPL^PSIVPRO S ON=9999999999-ON
- +2 DO HDR^PSJLMHED(DFN)
- +3 NEW PG,PSIVX2
- SET PSIVX2=0
- SET (PG,PSJLN,PRO)=1
- SET PSIVST="A"
- +4 DO HDL^PSIVPRO
- FOR X1=1:1
- SET ON=$ORDER(PS("A",ON))
- if ON=""
- QUIT
- SET ON55=ON
- DO GT55^PSIVORFB
- SET ON=9999999999-ON
- SET PSIVX1=ON55
- DO ENPL^PSIVPRO
- SET ON=9999999999-ON
- +5 NEW XX
- FOR XX=0:0
- SET XX=$ORDER(^TMP("PSJPRO",$JOB,XX))
- if 'XX
- QUIT
- WRITE !,^(XX,0)
- +6 if 'ON
- SET PRO=""
- +7 KILL ^TMP("PSJPRO",$JOB)
- +8 QUIT
- SETP ;
- +1 SET Y=^PS(55,DFN,"IV",ON,0)
- FOR X=1:1:23
- SET P(X)=$PIECE(Y,"^",X)
- +2 QUIT