PSGMMIV ;BIR/MV-IV ORDER FOR THE 7/14 DAY MAR. ;25 Nov 98 / 9:24 AM
;;5.0;INPATIENT MEDICATIONS;**20,21,58,111,131,145,267,275,326**;16 DEC 97;Build 1
;
; Reference to ^PS(52.7 supported by DBIA #2173.
; Reference to ^PS(55 supported by DBIA #2191.
;
START ;*** Read IV orders
NEW MULTIPG
S ON=""
F PSGMARED=PSGMARSD-.0001:0 S PSGMARED=$O(^PS(55,PSGP,"IV","AIT",PST,PSGMARED)) Q:'PSGMARED F S ON=$O(^PS(55,PSGP,"IV","AIT",PST,PSGMARED,ON)) Q:ON="" D IV
Q
IV ;*** Sort IV orders for 24 Hrs, 7/14 Day MAR.
K DRG,P N X,ON55,PSJLABEL S DFN=PSGP,PSJLABEL=1 D GT55^PSIVORFB
Q:P(2)>PSGMARFD
S X=$P(P("MR"),U,2) Q:XTYPE=2&(X["IV") Q:XTYPE=3&(PST="S")&'($S(X="IV":1,X="IVPB":1,1:0))
S QST=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3))
S QST=$S(P(9)["PRN":"OVP",QST="O":"OVO",1:"CV")_XTYPE
Q:(PSGMARS=2&(QST["C"))
Q:(PSGMARS=1&(QST["O"))
N PSGMARWC ;DEM (05/30/2006) - PSGMARWC is used to preserve original value of PSGMARWN (patient location) in case location is changed by an order with a clinic location.
S PSGMARWC=PSGMARWN
I $G(DRG) S X=$S($G(DRG("AD",1)):DRG("AD",1),1:$G(DRG("SOL",1))),X=$E($P(X,U,2),1,20)_U_+ON_"V" D
. N A
. S A=$G(^PS(55,PSGP,"IV",+ON,"DSS")) I ($P(A,"^",1)]"")&($P(A,"^",2)]"") S PSGMARWN="C!"_$P(A,"^") I $G(SUB1)]"",$G(SUB2)]"",'$D(^TMP($J,TM,PSGMARWN,SUB1,SUB2)) D
. . N X,Y
. . D SPN^PSGMMAR0
. . Q
. . ;
. I PSGSS="P" S ^TMP($J,PPN,PSGMARWN,$S(+PSGMSORT:$E(QST,1),1:QST),X)="" Q ;DAM 5-01-07 Print by PATIENT
. I PSGSS="L" Q:((PSGINWDG="")&(PSGMARWN'["C!")) S ^TMP($J,PPN,PSGMARWN,$S(+PSGMSORT:$E(QST,1),1:QST),X)="" Q ;DAM 5-01-07 Print by clinic group
. I PSGSS="C" Q:((PSGINWD="")&(PSGMARWN'["C!")) I ((PSGMARWN[PSGCLNC)!(PSGMARWN'["C!")) S ^TMP($J,PPN,PSGMARWN,$S(+PSGMSORT:$E(QST,1),1:QST),X)="" Q ;DAM 5-01-07 Print by Clinic
. ;
. ;DAM 5-01-07 Set up XTMP global where location and patient names are switched for printing by WARD/PATIENT or WARD GROUP/PATIENT
. I '$G(PSGREP) N PSGDEM1 S PSGDEM1=X D ;transfer contents of patient drug information contained in "X" above to a new variable temporarily
. . S PSGREP="PSGM_"_$J
. . S X1=DT,X2=1 D C^%DTC K %,%H,%T
. . S ^XTMP(PSGREP,0)=X_U_DT
. I PSGRBPPN="P",PSGSS="W" Q:((PSGINCL="")&(PSGMARWN["C!")) D ;Construct XTMP global for printing by WARD and sort by PATIENT
. . S ^XTMP(PSGREP,TM,PPN,PSGMARWN,PSJPRB,$S(+PSGMSORT:$E(QST,1),1:QST),PSGDEM1)=""
. . D SPN^PSGMMAR0
. I PSGRBPPN="P",PSGSS="G" Q:((PSGINCLG="")&(PSGMARWN["C!")) D ;Construct XTMP global for printing by WARD GROUP and sort by PATIENT
. . S ^XTMP(PSGREP,TM,PPN,PSGMARWN,PSJPRB,$S(+PSGMSORT:$E(QST,1),1:QST),PSGDEM1)=""
. . D SPN^PSGMMAR0
. S X=$G(PSGDEM1) ;Return value of X from PSGDEM1 back to X
. ;
. I PSGRBPPN="R",PSGSS="W" Q:((PSGINCL="")&(PSGMARWN["C!")) D ;Construct TMP global for printing by WARD and sort by ROOM/BED
. . S ^TMP($J,TM,PSGMARWN,PSJPRB,PPN,$S(+PSGMSORT:$E(QST,1),1:QST),X)=""
. I PSGRBPPN="R",PSGSS="G" Q:((PSGINCLG="")&(PSGMARWN["C!")) D ;Construct TMP global for printing by WARD GROUP and sort by ROOM/BED
. . S ^TMP($J,TM,PSGMARWN,PSJPRB,PPN,$S(+PSGMSORT:$E(QST,1),1:QST),X)=""
. ;End DAM modifications 5-01-07
. ;
S:PSGMARWN'=PSGMARWC PSGMARWN=PSGMARWC
Q
IVPRN ;*** Set ^tmp to store IV orders that have schedule of PRN.
K P,DRG NEW ON55,CHEMO,TXT,PSJLABEL,PSIVOPFL,PSIVOPIA
S ON=$P(DAOO,U,2),DFN=$P(PN,U,2),PSJLABEL=1
D:ON["V" GT55^PSIVORFB
D:ON["P" GT531^PSIVORFA(DFN,ON)
D SETVAR,SETLTRT
;the two naked references below refer to the full reference to the right of the = sign
S ^(1)=$G(^TMP($J,"1PRN",PG,LAB,1))_UP_" | |"
S ^(2)=$G(^TMP($J,"1PRN",PG,LAB,2))_UP_$E(P("LOG"),1,5)_" |",LN=3
;Naked reference below refers to ^TMP($J,"1PRN",PG,LAB,2)
S:ON["P" ^(2)=^(2)_"P E N D I N G"
;Naked reference below refers to ^TMP($J,"1PRN",PG,LAB,2)
S:ON["V" ^(2)=^(2)_$E(P(2),1,5)_$E(P(2),9,14)_" |"_P(3)
;Naked reference below refers to ^TMP($J,"1PRN",PG,LAB,2)
S ^(2)=$$SETSTR^VALM1("("_$E(PSGP(0))_$E(PSSN,8,12)_")",^(2),40,7)
F X=0:0 S X=$O(DRG("AD",X)) Q:'X S TXT=$$WRTDRG^PSIVUTL(DRG("AD",X),47) S:LN=3 TXT=TXT_$$SP(47-$L(TXT))_PSGST,PSGST="" D CHK(.TXT)
S TXT="in "
F X=0:0 S X=$O(DRG("SOL",X)) Q:'X D
. S TXT=TXT_$$WRTDRG^PSIVUTL(DRG("SOL",X),47) S:LN=3 TXT=TXT_$$SP(47-$L(TXT))_PSGST,PSGST="" D CHK(.TXT) S TXT=" "
. S PSJPRT2=$P(^PS(52.7,+DRG("SOL",X),0),U,4) I PSJPRT2]"" S TXT=TXT_" "_PSJPRT2 S:LN=3 TXT=TXT_$$SP(47-$L(TXT))_PSGST,PSGST="" D CHK(.TXT) S TXT=" "
S TXT=$P(P("MR"),U,2)_" "_P(9)_" "_P(8) D CHK(.TXT)
I P(4)="C" S CHEMO="*CAUTION-CHEMOTHERAPY*" D:P("OPI")]"" CHK(CHEMO)
S PSIVLOPI="",PSIVOPIA=1 S PSIVOPFL=$$OPI^PSGMIV(PSGP,ON55,.PSIVOPIA)
S Y1="" I '$G(PSIVOPFL) D
.F Y=1:1:$L($P(P("OPI"),"^")," ") S Y1=Y1_$P($P(P("OPI"),"^")," ",Y)_" " I $L(Y1)>47 D CHK(Y1) S Y1=""
.I $L(Y1)>28 D CHK(Y1) S Y1=""
.I $L(Y1)<29,'(LN#6) S TXT=$S((P("OPI")=""&$D(CHEMO)):CHEMO,1:Y1),X=29-$L(TXT),TXT=TXT_$$SP(X)_INIT
.E D S TXT=$$SP(29)_INIT,LN=LN+1
..;the following three naked references below refer to the full references to the right of the = sign
..I LN=5 S ^(LN)=$G(^TMP($J,"1PRN",PG,LAB,LN))_UP_Y1
..E D:$L(Y1) CHK(Y1) F LN=LN:1:5 S ^(LN)=$G(^TMP($J,"1PRN",PG,LAB,LN))_UP_""
.S ^(LN)=$G(^TMP($J,"1PRN",PG,LAB,LN))_UP_TXT
N POPI,YL S (POPI,YL,Y1,Y)="" I $G(PSIVOPFL) D
.F YL=1:1:+$O(PSIVOPIA(""),-1) S POPI=PSIVOPIA(YL) D
..I $O(PSIVOPIA(YL)) D CHK(POPI) S POPI="" Q
..I $L(POPI)>28 D CHK(POPI) S POPI=""
..I $L(POPI)<29,'(LN#6) S TXT=$S((POPI=""&$D(CHEMO)):CHEMO,1:POPI),X=29-$L(TXT),TXT=TXT_$$SP(X)_INIT
..E D S TXT=$$SP(29)_INIT,LN=LN+1
...;the following three naked references below refer to the full references to the right of the = sign
...I LN=5 S ^(LN)=$G(^TMP($J,"1PRN",PG,LAB,LN))_UP_POPI
...E D:$L(POPI) CHK(POPI) F LN=LN:1:5 S ^(LN)=$G(^TMP($J,"1PRN",PG,LAB,LN))_UP_""
..S ^(LN)=$G(^TMP($J,"1PRN",PG,LAB,LN))_UP_TXT
Q
SETVAR ;***Initialize variables.
NEW TMSTR
F X="LOG",2,3 S:P(X) P(X)=$$ENDTC^PSGMI(P(X))
S PSGST=$S(P(9)["PRN":"P",P(2)=P(3):"O",1:"C"),TMSTR=P(11),PSGLFFD=PSGMARFD
D INITOPI^PSGMMIVC
S INIT="RPH: "_PSGLRPH,INIT=INIT_$$SP(38-($L(INIT)+29))_"RN: "_PSGLRN
;*** If OPI<29 char, it is ok to put INITs in the same line.
;*** If OPI=""&it's a Chemo order, warning & Inits prt on same line.
;*** Add number lines needed for additives and solutions and 1 line
;*** for infusion rate and 1 line for start/stop date.
;*** Multiple labels can have up to 5 lines per label and the last
;*** label can have up to 6 lines..
;
NEW X S NAMENEED=0
F X="AD","SOL" D NAMENEED^PSJMUTL(X,47,.NEED) S NAMENEED=NAMENEED+NEED
S MULTIPG=0,NEED=1
;* Find # of lines needed for OPI -- (($L(P("OPI"))\47)
;* If the last line in OPI < 29 --(($L(P("OPI")#47)>28) include init.
S X=($L($P(P("OPI"),"^"))\47)+(($L($P(P("OPI"),"^"))#47)>28)+1+($P(P("OPI"),"^")]""&(P(4)="C"))
S X=(NAMENEED+X+2) S:X>5 NEED=((X-6)\5)+2
S:NEED>BL MULTIPG=1
Q
CHK(TXT) ;
;naked reference below refers to the full reference to the right of the = sign
I '(LN#6) S ^(LN)=$G(^TMP($J,"1PRN",PG,LAB,LN))_UP_"See next label for continuation",LN=1 D
. I PSGMAROC+1>(BL/2) D
. . I PSGMAROC=BL-1,MULTIPG D
. . .;naked reference below refers to the full reference to the right of the = sign
. . .F LN=LN:1:6 S ^(LN)=$G(^TMP($J,"1PRN",PG,LAB,LN))_UP_"" S:LN=3 ^(LN)=UP_"*** CONTINUE ON NEXT PAGE ***"
. . .S PG=PG+1,(LN,LT,RT)=1,(PSGMAROC,MULTIPG)=0 D LTRT^PSGMMAR3(.LT,"")
. . E D LTRT^PSGMMAR3(.RT,"^")
. E D LTRT^PSGMMAR3(.LT,"")
;naked reference below refers to the full reference to the right of the = sign
S ^(LN)=$G(^TMP($J,"1PRN",PG,LAB,LN))_UP_TXT,LN=LN+1,TXT=""
Q
SETLTRT ;*** Increment line number for left or right label on PRN sheet.
I (NEED+PSGMAROC)>BL S:PSGMAROC PG=PG+1,(LT,RT)=1,PSGMAROC=0
I NEED+PSGMAROC=BL D Q
. I PSGMAROC<(BL/2) D LTRT^PSGMMAR3(.LT,"")
. E D LTRT^PSGMMAR3(.RT,"^")
I PSGMAROC,((NEED+PSGMAROC)>(BL/2)) S PSGMAROC=$S(PSGMAROC>(BL/2):PSGMAROC,1:(BL/2)) D LTRT^PSGMMAR3(.RT,"^")
E D LTRT^PSGMMAR3(.LT,"")
Q
SP(X) ;***Set up spaces need between info on TXT for the label.
N Y S $P(Y," ",X)=" "
Q $G(Y)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGMMIV 8267 printed Oct 16, 2024@18:02:27 Page 2
PSGMMIV ;BIR/MV-IV ORDER FOR THE 7/14 DAY MAR. ;25 Nov 98 / 9:24 AM
+1 ;;5.0;INPATIENT MEDICATIONS;**20,21,58,111,131,145,267,275,326**;16 DEC 97;Build 1
+2 ;
+3 ; Reference to ^PS(52.7 supported by DBIA #2173.
+4 ; Reference to ^PS(55 supported by DBIA #2191.
+5 ;
START ;*** Read IV orders
+1 NEW MULTIPG
+2 SET ON=""
+3 FOR PSGMARED=PSGMARSD-.0001:0
SET PSGMARED=$ORDER(^PS(55,PSGP,"IV","AIT",PST,PSGMARED))
if 'PSGMARED
QUIT
FOR
SET ON=$ORDER(^PS(55,PSGP,"IV","AIT",PST,PSGMARED,ON))
if ON=""
QUIT
DO IV
+4 QUIT
IV ;*** Sort IV orders for 24 Hrs, 7/14 Day MAR.
+1 KILL DRG,P
NEW X,ON55,PSJLABEL
SET DFN=PSGP
SET PSJLABEL=1
DO GT55^PSIVORFB
+2 if P(2)>PSGMARFD
QUIT
+3 SET X=$PIECE(P("MR"),U,2)
if XTYPE=2&(X["IV")
QUIT
if XTYPE=3&(PST="S")&'($SELECT(X="IV"
QUIT
+4 SET QST=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3))
+5 SET QST=$SELECT(P(9)["PRN":"OVP",QST="O":"OVO",1:"CV")_XTYPE
+6 if (PSGMARS=2&(QST["C"))
QUIT
+7 if (PSGMARS=1&(QST["O"))
QUIT
+8 ;DEM (05/30/2006) - PSGMARWC is used to preserve original value of PSGMARWN (patient location) in case location is changed by an order with a clinic location.
NEW PSGMARWC
+9 SET PSGMARWC=PSGMARWN
+10 IF $GET(DRG)
SET X=$SELECT($GET(DRG("AD",1)):DRG("AD",1),1:$GET(DRG("SOL",1)))
SET X=$EXTRACT($PIECE(X,U,2),1,20)_U_+ON_"V"
Begin DoDot:1
+11 NEW A
+12 SET A=$GET(^PS(55,PSGP,"IV",+ON,"DSS"))
IF ($PIECE(A,"^",1)]"")&($PIECE(A,"^",2)]"")
SET PSGMARWN="C!"_$PIECE(A,"^")
IF $GET(SUB1)]""
IF $GET(SUB2)]""
IF '$DATA(^TMP($JOB,TM,PSGMARWN,SUB1,SUB2))
Begin DoDot:2
+13 NEW X,Y
+14 DO SPN^PSGMMAR0
+15 QUIT
+16 ;
End DoDot:2
+17 ;DAM 5-01-07 Print by PATIENT
IF PSGSS="P"
SET ^TMP($JOB,PPN,PSGMARWN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),X)=""
QUIT
+18 ;DAM 5-01-07 Print by clinic group
IF PSGSS="L"
if ((PSGINWDG="")&(PSGMARWN'["C!"))
QUIT
SET ^TMP($JOB,PPN,PSGMARWN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),X)=""
QUIT
+19 ;DAM 5-01-07 Print by Clinic
IF PSGSS="C"
if ((PSGINWD="")&(PSGMARWN'["C!"))
QUIT
IF ((PSGMARWN[PSGCLNC)!(PSGMARWN'["C!"))
SET ^TMP($JOB,PPN,PSGMARWN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),X)=""
QUIT
+20 ;
+21 ;DAM 5-01-07 Set up XTMP global where location and patient names are switched for printing by WARD/PATIENT or WARD GROUP/PATIENT
+22 ;transfer contents of patient drug information contained in "X" above to a new variable temporarily
IF '$GET(PSGREP)
NEW PSGDEM1
SET PSGDEM1=X
Begin DoDot:2
+23 SET PSGREP="PSGM_"_$JOB
+24 SET X1=DT
SET X2=1
DO C^%DTC
KILL %,%H,%T
+25 SET ^XTMP(PSGREP,0)=X_U_DT
End DoDot:2
+26 ;Construct XTMP global for printing by WARD and sort by PATIENT
IF PSGRBPPN="P"
IF PSGSS="W"
if ((PSGINCL="")&(PSGMARWN["C!"))
QUIT
Begin DoDot:2
+27 SET ^XTMP(PSGREP,TM,PPN,PSGMARWN,PSJPRB,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),PSGDEM1)=""
+28 DO SPN^PSGMMAR0
End DoDot:2
+29 ;Construct XTMP global for printing by WARD GROUP and sort by PATIENT
IF PSGRBPPN="P"
IF PSGSS="G"
if ((PSGINCLG="")&(PSGMARWN["C!"))
QUIT
Begin DoDot:2
+30 SET ^XTMP(PSGREP,TM,PPN,PSGMARWN,PSJPRB,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),PSGDEM1)=""
+31 DO SPN^PSGMMAR0
End DoDot:2
+32 ;Return value of X from PSGDEM1 back to X
SET X=$GET(PSGDEM1)
+33 ;
+34 ;Construct TMP global for printing by WARD and sort by ROOM/BED
IF PSGRBPPN="R"
IF PSGSS="W"
if ((PSGINCL="")&(PSGMARWN["C!"))
QUIT
Begin DoDot:2
+35 SET ^TMP($JOB,TM,PSGMARWN,PSJPRB,PPN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),X)=""
End DoDot:2
+36 ;Construct TMP global for printing by WARD GROUP and sort by ROOM/BED
IF PSGRBPPN="R"
IF PSGSS="G"
if ((PSGINCLG="")&(PSGMARWN["C!"))
QUIT
Begin DoDot:2
+37 SET ^TMP($JOB,TM,PSGMARWN,PSJPRB,PPN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),X)=""
End DoDot:2
+38 ;End DAM modifications 5-01-07
+39 ;
End DoDot:1
+40 if PSGMARWN'=PSGMARWC
SET PSGMARWN=PSGMARWC
+41 QUIT
IVPRN ;*** Set ^tmp to store IV orders that have schedule of PRN.
+1 KILL P,DRG
NEW ON55,CHEMO,TXT,PSJLABEL,PSIVOPFL,PSIVOPIA
+2 SET ON=$PIECE(DAOO,U,2)
SET DFN=$PIECE(PN,U,2)
SET PSJLABEL=1
+3 if ON["V"
DO GT55^PSIVORFB
+4 if ON["P"
DO GT531^PSIVORFA(DFN,ON)
+5 DO SETVAR
DO SETLTRT
+6 ;the two naked references below refer to the full reference to the right of the = sign
+7 SET ^(1)=$GET(^TMP($JOB,"1PRN",PG,LAB,1))_UP_" | |"
+8 SET ^(2)=$GET(^TMP($JOB,"1PRN",PG,LAB,2))_UP_$EXTRACT(P("LOG"),1,5)_" |"
SET LN=3
+9 ;Naked reference below refers to ^TMP($J,"1PRN",PG,LAB,2)
+10 if ON["P"
SET ^(2)=^(2)_"P E N D I N G"
+11 ;Naked reference below refers to ^TMP($J,"1PRN",PG,LAB,2)
+12 if ON["V"
SET ^(2)=^(2)_$EXTRACT(P(2),1,5)_$EXTRACT(P(2),9,14)_" |"_P(3)
+13 ;Naked reference below refers to ^TMP($J,"1PRN",PG,LAB,2)
+14 SET ^(2)=$$SETSTR^VALM1("("_$EXTRACT(PSGP(0))_$EXTRACT(PSSN,8,12)_")",^(2),40,7)
+15 FOR X=0:0
SET X=$ORDER(DRG("AD",X))
if 'X
QUIT
SET TXT=$$WRTDRG^PSIVUTL(DRG("AD",X),47)
if LN=3
SET TXT=TXT_$$SP(47-$LENGTH(TXT))_PSGST
SET PSGST=""
DO CHK(.TXT)
+16 SET TXT="in "
+17 FOR X=0:0
SET X=$ORDER(DRG("SOL",X))
if 'X
QUIT
Begin DoDot:1
+18 SET TXT=TXT_$$WRTDRG^PSIVUTL(DRG("SOL",X),47)
if LN=3
SET TXT=TXT_$$SP(47-$LENGTH(TXT))_PSGST
SET PSGST=""
DO CHK(.TXT)
SET TXT=" "
+19 SET PSJPRT2=$PIECE(^PS(52.7,+DRG("SOL",X),0),U,4)
IF PSJPRT2]""
SET TXT=TXT_" "_PSJPRT2
if LN=3
SET TXT=TXT_$$SP(47-$LENGTH(TXT))_PSGST
SET PSGST=""
DO CHK(.TXT)
SET TXT=" "
End DoDot:1
+20 SET TXT=$PIECE(P("MR"),U,2)_" "_P(9)_" "_P(8)
DO CHK(.TXT)
+21 IF P(4)="C"
SET CHEMO="*CAUTION-CHEMOTHERAPY*"
if P("OPI")]""
DO CHK(CHEMO)
+22 SET PSIVLOPI=""
SET PSIVOPIA=1
SET PSIVOPFL=$$OPI^PSGMIV(PSGP,ON55,.PSIVOPIA)
+23 SET Y1=""
IF '$GET(PSIVOPFL)
Begin DoDot:1
+24 FOR Y=1:1:$LENGTH($PIECE(P("OPI"),"^")," ")
SET Y1=Y1_$PIECE($PIECE(P("OPI"),"^")," ",Y)_" "
IF $LENGTH(Y1)>47
DO CHK(Y1)
SET Y1=""
+25 IF $LENGTH(Y1)>28
DO CHK(Y1)
SET Y1=""
+26 IF $LENGTH(Y1)<29
IF '(LN#6)
SET TXT=$SELECT((P("OPI")=""&$DATA(CHEMO)):CHEMO,1:Y1)
SET X=29-$LENGTH(TXT)
SET TXT=TXT_$$SP(X)_INIT
+27 IF '$TEST
Begin DoDot:2
+28 ;the following three naked references below refer to the full references to the right of the = sign
+29 IF LN=5
SET ^(LN)=$GET(^TMP($JOB,"1PRN",PG,LAB,LN))_UP_Y1
+30 IF '$TEST
if $LENGTH(Y1)
DO CHK(Y1)
FOR LN=LN:1:5
SET ^(LN)=$GET(^TMP($JOB,"1PRN",PG,LAB,LN))_UP_""
End DoDot:2
SET TXT=$$SP(29)_INIT
SET LN=LN+1
+31 SET ^(LN)=$GET(^TMP($JOB,"1PRN",PG,LAB,LN))_UP_TXT
End DoDot:1
+32 NEW POPI,YL
SET (POPI,YL,Y1,Y)=""
IF $GET(PSIVOPFL)
Begin DoDot:1
+33 FOR YL=1:1:+$ORDER(PSIVOPIA(""),-1)
SET POPI=PSIVOPIA(YL)
Begin DoDot:2
+34 IF $ORDER(PSIVOPIA(YL))
DO CHK(POPI)
SET POPI=""
QUIT
+35 IF $LENGTH(POPI)>28
DO CHK(POPI)
SET POPI=""
+36 IF $LENGTH(POPI)<29
IF '(LN#6)
SET TXT=$SELECT((POPI=""&$DATA(CHEMO)):CHEMO,1:POPI)
SET X=29-$LENGTH(TXT)
SET TXT=TXT_$$SP(X)_INIT
+37 IF '$TEST
Begin DoDot:3
+38 ;the following three naked references below refer to the full references to the right of the = sign
+39 IF LN=5
SET ^(LN)=$GET(^TMP($JOB,"1PRN",PG,LAB,LN))_UP_POPI
+40 IF '$TEST
if $LENGTH(POPI)
DO CHK(POPI)
FOR LN=LN:1:5
SET ^(LN)=$GET(^TMP($JOB,"1PRN",PG,LAB,LN))_UP_""
End DoDot:3
SET TXT=$$SP(29)_INIT
SET LN=LN+1
+41 SET ^(LN)=$GET(^TMP($JOB,"1PRN",PG,LAB,LN))_UP_TXT
End DoDot:2
End DoDot:1
+42 QUIT
SETVAR ;***Initialize variables.
+1 NEW TMSTR
+2 FOR X="LOG",2,3
if P(X)
SET P(X)=$$ENDTC^PSGMI(P(X))
+3 SET PSGST=$SELECT(P(9)["PRN":"P",P(2)=P(3):"O",1:"C")
SET TMSTR=P(11)
SET PSGLFFD=PSGMARFD
+4 DO INITOPI^PSGMMIVC
+5 SET INIT="RPH: "_PSGLRPH
SET INIT=INIT_$$SP(38-($LENGTH(INIT)+29))_"RN: "_PSGLRN
+6 ;*** If OPI<29 char, it is ok to put INITs in the same line.
+7 ;*** If OPI=""&it's a Chemo order, warning & Inits prt on same line.
+8 ;*** Add number lines needed for additives and solutions and 1 line
+9 ;*** for infusion rate and 1 line for start/stop date.
+10 ;*** Multiple labels can have up to 5 lines per label and the last
+11 ;*** label can have up to 6 lines..
+12 ;
+13 NEW X
SET NAMENEED=0
+14 FOR X="AD","SOL"
DO NAMENEED^PSJMUTL(X,47,.NEED)
SET NAMENEED=NAMENEED+NEED
+15 SET MULTIPG=0
SET NEED=1
+16 ;* Find # of lines needed for OPI -- (($L(P("OPI"))\47)
+17 ;* If the last line in OPI < 29 --(($L(P("OPI")#47)>28) include init.
+18 SET X=($LENGTH($PIECE(P("OPI"),"^"))\47)+(($LENGTH($PIECE(P("OPI"),"^"))#47)>28)+1+($PIECE(P("OPI"),"^")]""&(P(4)="C"))
+19 SET X=(NAMENEED+X+2)
if X>5
SET NEED=((X-6)\5)+2
+20 if NEED>BL
SET MULTIPG=1
+21 QUIT
CHK(TXT) ;
+1 ;naked reference below refers to the full reference to the right of the = sign
+2 IF '(LN#6)
SET ^(LN)=$GET(^TMP($JOB,"1PRN",PG,LAB,LN))_UP_"See next label for continuation"
SET LN=1
Begin DoDot:1
+3 IF PSGMAROC+1>(BL/2)
Begin DoDot:2
+4 IF PSGMAROC=BL-1
IF MULTIPG
Begin DoDot:3
+5 ;naked reference below refers to the full reference to the right of the = sign
+6 FOR LN=LN:1:6
SET ^(LN)=$GET(^TMP($JOB,"1PRN",PG,LAB,LN))_UP_""
if LN=3
SET ^(LN)=UP_"*** CONTINUE ON NEXT PAGE ***"
+7 SET PG=PG+1
SET (LN,LT,RT)=1
SET (PSGMAROC,MULTIPG)=0
DO LTRT^PSGMMAR3(.LT,"")
End DoDot:3
+8 IF '$TEST
DO LTRT^PSGMMAR3(.RT,"^")
End DoDot:2
+9 IF '$TEST
DO LTRT^PSGMMAR3(.LT,"")
End DoDot:1
+10 ;naked reference below refers to the full reference to the right of the = sign
+11 SET ^(LN)=$GET(^TMP($JOB,"1PRN",PG,LAB,LN))_UP_TXT
SET LN=LN+1
SET TXT=""
+12 QUIT
SETLTRT ;*** Increment line number for left or right label on PRN sheet.
+1 IF (NEED+PSGMAROC)>BL
if PSGMAROC
SET PG=PG+1
SET (LT,RT)=1
SET PSGMAROC=0
+2 IF NEED+PSGMAROC=BL
Begin DoDot:1
+3 IF PSGMAROC<(BL/2)
DO LTRT^PSGMMAR3(.LT,"")
+4 IF '$TEST
DO LTRT^PSGMMAR3(.RT,"^")
End DoDot:1
QUIT
+5 IF PSGMAROC
IF ((NEED+PSGMAROC)>(BL/2))
SET PSGMAROC=$SELECT(PSGMAROC>(BL/2):PSGMAROC,1:(BL/2))
DO LTRT^PSGMMAR3(.RT,"^")
+6 IF '$TEST
DO LTRT^PSGMMAR3(.LT,"")
+7 QUIT
SP(X) ;***Set up spaces need between info on TXT for the label.
+1 NEW Y
SET $PIECE(Y," ",X)=" "
+2 QUIT $GET(Y)
