PSGMMIV.m

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**;16 DEC 97;Build 17

 ;

 ; 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,"^")]"" 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

 S ON=$P(DAOO,U,2),DFN=$P(PN,U,2),PSJLABEL=1

 ;* D:PST'["Z" GT55^PSIVORFB

 ;* I PST["Z" D GT531^PSIVORFA(DFN,ON)

 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

 ;* S:PST["Z" ^(2)=^(2)_"P E N D I N G"

 ;* S:PST'["Z" ^(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: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  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="   "

 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 Y1="" 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 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

 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(37-($L(INIT)+29))_"RN: "_PSGLRN

 S INIT="RPH: "_PSGLRPH,INIT=INIT_$$SP(38-($L(INIT)+29))_"RN: "_PSGLRN

 ;* S INIT="RPH: "_PSGLRPH_" RN: "_PSGLRN

 ;* S INIT="RPH: "_$S(PSGLRPH]"":PSGLRPH_" ",1:"_____")_" RN: "_$S($G(PSGLRN)]"":PSGLRN,1:"_____")

 ;*** 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

 ;* S X=($L(P("OPI"))>28)+1+(P("OPI")]""&(P(4)="C"))

 ;* 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)

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**;16 DEC 97;Build 17

 +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,"^")]""

                       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

 +2        SET ON=$PIECE(DAOO,U,2)

           SET DFN=$PIECE(PN,U,2)

           SET PSJLABEL=1

 +3       ;* D:PST'["Z" GT55^PSIVORFB

 +4       ;* I PST["Z" D GT531^PSIVORFA(DFN,ON)

 +5        IF ON["V"

               DO GT55^PSIVORFB

 +6        IF ON["P"

               DO GT531^PSIVORFA(DFN,ON)

 +7        DO SETVAR

           DO SETLTRT

 +8       ;the two naked references below refer to the full reference to the right of the = sign

 +9        SET ^(1)=$GET(^TMP($JOB,"1PRN",PG,LAB,1))_UP_"      |            |"

 +10       SET ^(2)=$GET(^TMP($JOB,"1PRN",PG,LAB,2))_UP_$EXTRACT(P("LOG"),1,5)_" |"

           SET LN=3

 +11      ;* S:PST["Z" ^(2)=^(2)_"P E N D I N G"

 +12      ;* S:PST'["Z" ^(2)=^(2)_$E(P(2),1,5)_$E(P(2),9,14)_" |"_P(3)

 +13      ;Naked reference below refers to ^TMP($J,"1PRN",PG,LAB,2)

 +14       IF ON["P"

               SET ^(2)=^(2)_"P E N D I N G"

 +15      ;Naked reference below refers to ^TMP($J,"1PRN",PG,LAB,2)

 +16       IF ON["V"

               SET ^(2)=^(2)_$EXTRACT(P(2),1,5)_$EXTRACT(P(2),9,14)_" |"_P(3)

 +17      ;Naked reference below refers to ^TMP($J,"1PRN",PG,LAB,2)

 +18       SET ^(2)=$$SETSTR^VALM1("("_$EXTRACT(PSGP(0))_$EXTRACT(PSSN,8,12)_")",^(2),40,7)

 +19       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)

 +20       SET TXT="in "

 +21      ;; F X=0:0 S X=$O(DRG("SOL",X)) Q:'X  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="   "

 +22       FOR X=0:0

               SET X=$ORDER(DRG("SOL",X))

               IF 'X

                   QUIT 

               Begin DoDot:1

 +23               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="   "

 +24               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

 +25       SET TXT=$PIECE(P("MR"),U,2)_" "_P(9)_" "_P(8)

           DO CHK(.TXT)

 +26       IF P(4)="C"

               SET CHEMO="*CAUTION-CHEMOTHERAPY*"

               IF P("OPI")]""

                   DO CHK(CHEMO)

 +27       SET Y1=""

           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=""

 +28       IF $LENGTH(Y1)>28

               DO CHK(Y1)

               SET Y1=""

 +29       IF 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

 +30      IF '$TEST

               Begin DoDot:1

 +31      ;the following three naked references below refer to the full references to the right of the = sign

 +32               IF LN=5

                       SET ^(LN)=$GET(^TMP($JOB,"1PRN",PG,LAB,LN))_UP_Y1

 +33              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:1

               SET TXT=$$SP(29)_INIT

               SET LN=LN+1

 +34       SET ^(LN)=$GET(^TMP($JOB,"1PRN",PG,LAB,LN))_UP_TXT

 +35       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       ;;S INIT="RPH: "_PSGLRPH,INIT=INIT_$$SP(37-($L(INIT)+29))_"RN: "_PSGLRN

 +6        SET INIT="RPH: "_PSGLRPH

           SET INIT=INIT_$$SP(38-($LENGTH(INIT)+29))_"RN: "_PSGLRN

 +7       ;* S INIT="RPH: "_PSGLRPH_" RN: "_PSGLRN

 +8       ;* S INIT="RPH: "_$S(PSGLRPH]"":PSGLRPH_" ",1:"_____")_" RN: "_$S($G(PSGLRN)]"":PSGLRN,1:"_____")

 +9       ;*** If OPI<29 char, it is ok to put INITs in the same line.

 +10      ;*** If OPI=""&it's a Chemo order, warning & Inits prt on same line.

 +11      ;*** Add number lines needed for additives and solutions and 1 line

 +12      ;*** for infusion rate and 1 line for start/stop date.

 +13      ;*** Multiple labels can have up to 5 lines per label and the last

 +14      ;*** label can have up to 6 lines..

 +15      ;

 +16       NEW X

           SET NAMENEED=0

 +17       FOR X="AD","SOL"

               DO NAMENEED^PSJMUTL(X,47,.NEED)

               SET NAMENEED=NAMENEED+NEED

 +18       SET MULTIPG=0

           SET NEED=1

 +19      ;* S X=($L(P("OPI"))>28)+1+(P("OPI")]""&(P(4)="C"))

 +20      ;* Find # of lines needed for OPI -- (($L(P("OPI"))\47)

 +21      ;* If the last line in OPI < 29 --(($L(P("OPI")#47)>28) include init.

 +22       SET X=($LENGTH($PIECE(P("OPI"),"^"))\47)+(($LENGTH($PIECE(P("OPI"),"^"))#47)>28)+1+($PIECE(P("OPI"),"^")]""&(P(4)="C"))

 +23       SET X=(NAMENEED+X+2)

           IF X>5

               SET NEED=((X-6)\5)+2

 +24       IF NEED>BL

               SET MULTIPG=1

 +25       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)