PSGMIV.m

PSGMIV ;BIR/MV-IV ORDER FOR THE 24 HOUR MAR. ;03-Apr-2012 10:34;PLS

 ;;5.0; INPATIENT MEDICATIONS ;**4,20,21,28,58,1013,111,131,145,1014**;16 DEC 97;Build 62

 ;

 ; Reference to ^PS(55 supported by DBIA #2191.

 ; Reference to ^PS(52.7 supported by DBIA #2173.

 ; Modified - IHS/MSC/PLS - 10/12/2011 - Line PRTIV+20, L+2

 ;

START ;*** Read IV orders

 S ON=""

 F PSGMARED=PSGPLS-.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 MAR.

 K DRG,P N X,ON55,PSJLABEL S DFN=PSGP,PSJLABEL=1 D GT55^PSIVORFB

 Q:P(2)>PSGPLF

 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

 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,X1,Y

 . . D SPN^PSGMAR0

 . . 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

 . 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^PSGMAR0

 . 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^PSGMAR0

 . S X=$G(PSGDEM1)

 . ;END DAM

 . ;

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

 . ;

 S:PSGMARWN'=PSGMARWC PSGMARWN=PSGMARWC

 ;

 Q

PRT ;*** Print IV orders.

 K TS,P,DRG NEW ON55,LN,PSJLABEL S PSJLABEL=1

 S ON=$P(DAO,U,2),DFN=$P(PN,U,2) D:ON["V" GT55^PSIVORFB

 D:ON["P" GT531^PSIVORFA(DFN,ON)

 S TS=1,TMSTR="" I P(9)]"" D ORSET,TS^PSGMAR3(P(11))

 F X="LOG",2,3 S:P(X) P(X)=$$ENDTC1^PSGMI(P(X))

 S PSGST=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3)) I PSGST'="O" S PSGST=$S(P(9)["PRN":"P",1:"C")

 S PSGLFFD=PSGPLF

 D INITOPI^PSGMMIVC

 NEW NAMENEED,NEED,X S NAMENEED=0

 D LNNEED,PRTIV

 Q

LNNEED ;*** Find lines needed per label.

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

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

 ;*** for infusion rate and x line for OPI. Divide by 5 to determine

 ;*** of label(s) needed for this order.

 F X="AD","SOL" D NAMENEED^PSJMUTL(X,47,.NEED) S NAMENEED=NAMENEED+NEED

 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=$S(X<6:1,1:((X-6)\5)+2)

 S LN=$S(TS/6>X:TS/6,1:X)

 Q

 ;

OS ; order record set

 Q

 ;

PRTIV ;*** Print IV order on MAR

 D ONHOLD^PSGMMAR2

 I PSGMAROC,(PSGMAROC+LN)>6 D BOT^PSGMAR3,HEADER^PSGMAR3

 NEW PSGL S PSGL="|"

 S PSGMAROC=PSGMAROC+1 W !?6,"|",?19,"|",?48,PSGL,$G(TS(1)),?55,"|"

 W !,$E(P("LOG"),1,5)," |"

 I ON["V" D

 . I $G(ONHOLD) W "O N  H O L D" Q

 . W $E(P(2),1,5)_$E(P(2),9,14)," |",P(3)

 . Q

 W:ON["P" "P E N D I N G"

 W ?39,"(",$E(PSGP(0))_$E(PSSN,8,12)_")"

 W ?48,PSGL,$G(TS(2)),?55,"|" S L=3

 NEW NAME,PSIVX

 F PSIVX=0:0 S PSIVX=$O(DRG("AD",PSIVX)) Q:'PSIVX  D NAME^PSIVUTL(DRG("AD",PSIVX),47,.NAME,1) F Y=0:0 S Y=$O(NAME(Y)) Q:'Y  W !,NAME(Y) W:L=3 ?47,PSGST W ?48,PSGL,$G(TS(L)),?55,"|" D:(PSIVX=1&((PSGST="O")!(PSGST="C"))) TMSTR^PSGMAR3 D L(1)

 W:$G(DRG("SOL",0)) !,"in "

 NEW PSJPRT2

 F PSIVX=0:0 S PSIVX=$O(DRG("SOL",PSIVX)) Q:'PSIVX  D NAME^PSIVUTL(DRG("SOL",PSIVX),47,.NAME,1) F Y=0:0 S Y=$O(NAME(Y)) Q:'Y  D

 . W:(Y>1!(PSIVX>1)) ! W ?4,NAME(Y) W:L=3 ?47,PSGST W ?48,PSGL,$G(TS(L)),?55,"|" D:L=3 TMSTR^PSGMAR3 D L(1)

 . S PSJPRT2=$P(^PS(52.7,+DRG("SOL",PSIVX),0),U,4) I PSJPRT2]"" W !?7,PSJPRT2 W:L=3 ?47,PSGST W ?48,PSGL,$G(TS(L)),?55,"|" D:L=3 TMSTR^PSGMAR3 D L(1)

 W !,$P(P("MR"),U,2)," ",P(9)," ",P(8) W ?48,PSGL,$G(TS(L)),?55,"|" I L>5,(L#5) W !

 I '$O(DRG("AD",0))!('$O(DRG("SOL",0))) W !?48,PSGL,$G(TS(L)),?55,"|" S L=5

 I P(4)="C",'(L#5),P("OPI")="" W !,"*CAUTION-CHEMOTHERAPY*" S L=L+1 Q

 I P(4)="C" D L(1) W !,"*CAUTION-CHEMOTHERAPY*",?48,PSGL,$G(TS(L)),?55,"|"

 ;IHS/MSC/PLS - 10/12/2011

 I (L#5)=0,($L($P(P("OPI"),"^"))<29),(TS<7) S L=L+1

 E  D L(1)

 ;I $L($P(P("OPI"),U)) D L(1) W !

 ;E  S L=L+1

 W:P("OPI")=""&(TS>6) !

 I P("OPI")'="" D

 .; W:(L#6)=1 !  ;IHS/MSC/PLS - 10/12/2011 - Changed to match PSJ*5.0*145

 . W:(L#6)=0 !

 . F Y=1:1:$L($P(P("OPI"),"^")," ") S Y1=$P($P(P("OPI"),"^")," ",Y) D  W Y1," "

 . I ($X+$L(Y1))>47 W ?48,PSGL,$G(TS(L)),?55,"|" D L(1) W !

 I L>TS,(L#6) W ?48,PSGL,$G(TS(L)),?55,"|" S L=L+1 W:L#6=0 !

 I (TS-1)>L W ?48,PSGL,$G(TS(L)),?55,"|" D

 . F L=L+1:1:TS-1 D L(0) W !?48,PSGL,$G(TS(L)),?55,"|"

 . S L=L+1

 F  Q:'(L#6)  W !?48,PSGL,$G(TS(L)),?55,"|" S L=L+1

 I '(L#6),(P("OPI")="") W !

 I P("OPI")]"",(L>6) W !

 W ?29,"RPH: ",PSGLRPH,?38,"RN: ",PSGLRN,?48,PSGL,$G(TS(L)),?55,"|" W:PSGMAROC<6 !?7,LN2

 Q

 ;

L(X) ;***Check to see if a new block is needed.

 S L=L+X

 ;IHS/MSC/PLS - 10/12/2011

 ;I L#6=0,PSGMAROC<6 W !,"See next label for continuation",?48,PSGL,$G(TS(L)),?55,"|" W:PSGMAROC<6 !?7,LN2 S PSGMAROC=PSGMAROC+1,L=L+1 D

 I L#6=0,PSGMAROC<6 W !,"See next label for continuation",?48,PSGL,$G(TS(L)),?55,"|" W:PSGMAROC<6 !?7,LN2,! S PSGMAROC=PSGMAROC+1,L=L+1 D

 .I LN>6,(PSGMAROC>5) S MSG1="*** CONTINUE ON NEXT PAGE ***" D BOT^PSGMAR3,HEADER^PSGMAR3 S PSGMAROC=1

 Q

ORSET ; order record set

 Q:PST["P"!P(9)=""

 S PSGMFOR="",(SD,X)=$P(P(2),".") Q:X>PSGPLF  S FD=$P(P(3),"."),PSGOES="",X=P(9) D EN^PSGS0 S T=PSGS0XT

 S X="" I "OB"]PST,$P(P(9),"^")'["@",P(2)'>PSGPLS,P(3)'<PSGPLF,P(11),T<1441,T'="D" S X=P(11),PSGPLC=1

 E  I "OB"]PST!(PST["OV") K PSGMAR D SETL0 S (Q,X)="" F QX=0:0 S Q=$O(PSGMAR(Q)) Q:Q=""  S X=X_$E("0",2-$L(Q))_Q_"-"

 S TMSTR=X

 K HCD,HM,I,J,PSGD,PLSD,CD,M,MID,MN,ND,ND1,OD,ST,QD1,QD2,QQ,TS,UD,WDT,WS,WS1,X,X1,X2 Q

 Q

SETL0 ;*** Set variable to use in ^PSGPL0 to calculate admin time.

 K PSGMAR S PSGPLC=0

 S ND1=P(4),ST=P(2),PLSD=P(3),TS=P(11),MN=T,ND=P(9) I $S(ST'?7N1"."1N.E:1,1:PLSD'?7N1"."1N.E) S PSGPLC="OI" Q

 D ENIV^PSGPL0

 Q

 ;

RPHINIT(RPH) ; Find initial for the person who completed the IV order.

 S RPH=$P($G(^PS(55,PSGP,"IV",+ON,4)),U,4)

 S:+RPH RPH=$$DEFINIT(+RPH)

 I RPH="" S RPH="_____"

 Q

DEFINIT(X) ;

 S X=$G(^VA(200,X,0)),RPH=$P(X,U,2) Q:RPH]"" RPH

 S X=$P(X,U),RPH=$E(X,$F(X,","))_$E(X) Q RPH

PSGMIV    ;BIR/MV-IV ORDER FOR THE 24 HOUR MAR. ;03-Apr-2012 10:34;PLS

 +1       ;;5.0; INPATIENT MEDICATIONS ;**4,20,21,28,58,1013,111,131,145,1014**;16 DEC 97;Build 62

 +2       ;

 +3       ; Reference to ^PS(55 supported by DBIA #2191.

 +4       ; Reference to ^PS(52.7 supported by DBIA #2173.

 +5       ; Modified - IHS/MSC/PLS - 10/12/2011 - Line PRTIV+20, L+2

 +6       ;

START     ;*** Read IV orders

 +1        SET ON=""

 +2        FOR PSGMARED=PSGPLS-.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

 +3        QUIT 

IV        ;*** Sort IV orders for 24 Hrs MAR.

 +1        KILL DRG,P

           NEW X,ON55,PSJLABEL

           SET DFN=PSGP

           SET PSJLABEL=1

           DO GT55^PSIVORFB

 +2        IF P(2)>PSGPLF

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

 +7        SET PSGMARWC=PSGMARWN

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

 +9                NEW A

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

 +11                                   NEW X,X1,Y

 +12                                   DO SPN^PSGMAR0

 +13                                   QUIT 

 +14      ;

                                   End DoDot:2

 +15      ;DAM 5-01-07 Print by PATIENT

                   IF PSGSS="P"

                       SET ^TMP($JOB,PPN,PSGMARWN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),X)=""

                       QUIT 

 +16      ;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 

 +17      ;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 

 +18      ;

 +19      ;DAM 5-01-07 Set up XTMP global where location and patient names are switched

 +20      ;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

 +21                       SET PSGREP="PSGM_"_$JOB

 +22                       SET X1=DT

                           SET X2=1

                           DO C^%DTC

                           KILL %,%H,%T

 +23                       SET ^XTMP(PSGREP,0)=X_U_DT

                       End DoDot:2

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

 +25                           SET ^XTMP(PSGREP,TM,PPN,PSGMARWN,PSJPRB,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),PSGDEM1)=""

 +26                           DO SPN^PSGMAR0

                           End DoDot:2

 +27      ;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

 +28                           SET ^XTMP(PSGREP,TM,PPN,PSGMARWN,PSJPRB,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),PSGDEM1)=""

 +29                           DO SPN^PSGMAR0

                           End DoDot:2

 +30               SET X=$GET(PSGDEM1)

 +31      ;END DAM

 +32      ;

 +33      ;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

 +34                           SET ^TMP($JOB,TM,PSGMARWN,PSJPRB,PPN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),X)=""

                           End DoDot:2

 +35      ;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

 +36                           SET ^TMP($JOB,TM,PSGMARWN,PSJPRB,PPN,$SELECT(+PSGMSORT:$EXTRACT(QST,1),1:QST),X)=""

                           End DoDot:2

 +37      ;

               End DoDot:1

 +38       IF PSGMARWN'=PSGMARWC

               SET PSGMARWN=PSGMARWC

 +39      ;

 +40       QUIT 

PRT       ;*** Print IV orders.

 +1        KILL TS,P,DRG

           NEW ON55,LN,PSJLABEL

           SET PSJLABEL=1

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

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

           IF ON["V"

               DO GT55^PSIVORFB

 +3        IF ON["P"

               DO GT531^PSIVORFA(DFN,ON)

 +4        SET TS=1

           SET TMSTR=""

           IF P(9)]""

               DO ORSET

               DO TS^PSGMAR3(P(11))

 +5        FOR X="LOG",2,3

               IF P(X)

                   SET P(X)=$$ENDTC1^PSGMI(P(X))

 +6        SET PSGST=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3))

           IF PSGST'="O"

               SET PSGST=$SELECT(P(9)["PRN":"P",1:"C")

 +7        SET PSGLFFD=PSGPLF

 +8        DO INITOPI^PSGMMIVC

 +9        NEW NAMENEED,NEED,X

           SET NAMENEED=0

 +10       DO LNNEED

           DO PRTIV

 +11       QUIT 

LNNEED    ;*** Find lines needed per label.

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

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

 +3       ;*** for infusion rate and x line for OPI. Divide by 5 to determine

 +4       ;*** of label(s) needed for this order.

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

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

               SET NAMENEED=NAMENEED+NEED

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

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

           SET X=$SELECT(X<6:1,1:((X-6)\5)+2)

 +8        SET LN=$SELECT(TS/6>X:TS/6,1:X)

 +9        QUIT 

 +10      ;

OS        ; order record set

 +1        QUIT 

 +2       ;

PRTIV     ;*** Print IV order on MAR

 +1        DO ONHOLD^PSGMMAR2

 +2        IF PSGMAROC

               IF (PSGMAROC+LN)>6

                   DO BOT^PSGMAR3

                   DO HEADER^PSGMAR3

 +3        NEW PSGL

           SET PSGL="|"

 +4        SET PSGMAROC=PSGMAROC+1

           WRITE !?6,"|",?19,"|",?48,PSGL,$GET(TS(1)),?55,"|"

 +5        WRITE !,$EXTRACT(P("LOG"),1,5)," |"

 +6        IF ON["V"

               Begin DoDot:1

 +7                IF $GET(ONHOLD)

                       WRITE "O N  H O L D"

                       QUIT 

 +8                WRITE $EXTRACT(P(2),1,5)_$EXTRACT(P(2),9,14)," |",P(3)

 +9                QUIT 

               End DoDot:1

 +10       IF ON["P"

               WRITE "P E N D I N G"

 +11       WRITE ?39,"(",$EXTRACT(PSGP(0))_$EXTRACT(PSSN,8,12)_")"

 +12       WRITE ?48,PSGL,$GET(TS(2)),?55,"|"

           SET L=3

 +13       NEW NAME,PSIVX

 +14       FOR PSIVX=0:0

               SET PSIVX=$ORDER(DRG("AD",PSIVX))

               IF 'PSIVX

                   QUIT 

               DO NAME^PSIVUTL(DRG("AD",PSIVX),47,.NAME,1)

               FOR Y=0:0

                   SET Y=$ORDER(NAME(Y))

                   IF 'Y

                       QUIT 

                   WRITE !,NAME(Y)

                   IF L=3

                       WRITE ?47,PSGST

                   WRITE ?48,PSGL,$GET(TS(L)),?55,"|"

                   IF (PSIVX=1&((PSGST="O")!(PSGST="C")))

                       DO TMSTR^PSGMAR3

                   DO L(1)

 +15       IF $GET(DRG("SOL",0))

               WRITE !,"in "

 +16       NEW PSJPRT2

 +17       FOR PSIVX=0:0

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

               IF 'PSIVX

                   QUIT 

               DO NAME^PSIVUTL(DRG("SOL",PSIVX),47,.NAME,1)

               FOR Y=0:0

                   SET Y=$ORDER(NAME(Y))

                   IF 'Y

                       QUIT 

                   Begin DoDot:1

 +18                   IF (Y>1!(PSIVX>1))

                           WRITE !

                       WRITE ?4,NAME(Y)

                       IF L=3

                           WRITE ?47,PSGST

                       WRITE ?48,PSGL,$GET(TS(L)),?55,"|"

                       IF L=3

                           DO TMSTR^PSGMAR3

                       DO L(1)

 +19                   SET PSJPRT2=$PIECE(^PS(52.7,+DRG("SOL",PSIVX),0),U,4)

                       IF PSJPRT2]""

                           WRITE !?7,PSJPRT2

                           IF L=3

                               WRITE ?47,PSGST

                           WRITE ?48,PSGL,$GET(TS(L)),?55,"|"

                           IF L=3

                               DO TMSTR^PSGMAR3

                           DO L(1)

                   End DoDot:1

 +20       WRITE !,$PIECE(P("MR"),U,2)," ",P(9)," ",P(8)

           WRITE ?48,PSGL,$GET(TS(L)),?55,"|"

           IF L>5

               IF (L#5)

                   WRITE !

 +21       IF '$ORDER(DRG("AD",0))!('$ORDER(DRG("SOL",0)))

               WRITE !?48,PSGL,$GET(TS(L)),?55,"|"

               SET L=5

 +22       IF P(4)="C"

               IF '(L#5)

                   IF P("OPI")=""

                       WRITE !,"*CAUTION-CHEMOTHERAPY*"

                       SET L=L+1

                       QUIT 

 +23       IF P(4)="C"

               DO L(1)

               WRITE !,"*CAUTION-CHEMOTHERAPY*",?48,PSGL,$GET(TS(L)),?55,"|"

 +24      ;IHS/MSC/PLS - 10/12/2011

 +25       IF (L#5)=0

               IF ($LENGTH($PIECE(P("OPI"),"^"))<29)

                   IF (TS<7)

                       SET L=L+1

 +26      IF '$TEST

               DO L(1)

 +27      ;I $L($P(P("OPI"),U)) D L(1) W !

 +28      ;E  S L=L+1

 +29       IF P("OPI")=""&(TS>6)

               WRITE !

 +30       IF P("OPI")'=""

               Begin DoDot:1

 +31      ; W:(L#6)=1 !  ;IHS/MSC/PLS - 10/12/2011 - Changed to match PSJ*5.0*145

 +32               IF (L#6)=0

                       WRITE !

 +33               FOR Y=1:1:$LENGTH($PIECE(P("OPI"),"^")," ")

                       SET Y1=$PIECE($PIECE(P("OPI"),"^")," ",Y)

                       Begin DoDot:2

                       End DoDot:2

                       WRITE Y1," "

 +34               IF ($X+$LENGTH(Y1))>47

                       WRITE ?48,PSGL,$GET(TS(L)),?55,"|"

                       DO L(1)

                       WRITE !

               End DoDot:1

 +35       IF L>TS

               IF (L#6)

                   WRITE ?48,PSGL,$GET(TS(L)),?55,"|"

                   SET L=L+1

                   IF L#6=0

                       WRITE !

 +36       IF (TS-1)>L

               WRITE ?48,PSGL,$GET(TS(L)),?55,"|"

               Begin DoDot:1

 +37               FOR L=L+1:1:TS-1

                       DO L(0)

                       WRITE !?48,PSGL,$GET(TS(L)),?55,"|"

 +38               SET L=L+1

               End DoDot:1

 +39       FOR 

               IF '(L#6)

                   QUIT 

               WRITE !?48,PSGL,$GET(TS(L)),?55,"|"

               SET L=L+1

 +40       IF '(L#6)

               IF (P("OPI")="")

                   WRITE !

 +41       IF P("OPI")]""

               IF (L>6)

                   WRITE !

 +42       WRITE ?29,"RPH: ",PSGLRPH,?38,"RN: ",PSGLRN,?48,PSGL,$GET(TS(L)),?55,"|"

           IF PSGMAROC<6

               WRITE !?7,LN2

 +43       QUIT 

 +44      ;

L(X)      ;***Check to see if a new block is needed.

 +1        SET L=L+X

 +2       ;IHS/MSC/PLS - 10/12/2011

 +3       ;I L#6=0,PSGMAROC<6 W !,"See next label for continuation",?48,PSGL,$G(TS(L)),?55,"|" W:PSGMAROC<6 !?7,LN2 S PSGMAROC=PSGMAROC+1,L=L+1 D

 +4        IF L#6=0

               IF PSGMAROC<6

                   WRITE !,"See next label for continuation",?48,PSGL,$GET(TS(L)),?55,"|"

                   IF PSGMAROC<6

                       WRITE !?7,LN2,!

                   SET PSGMAROC=PSGMAROC+1

                   SET L=L+1

                   Begin DoDot:1

 +5                    IF LN>6

                           IF (PSGMAROC>5)

                               SET MSG1="*** CONTINUE ON NEXT PAGE ***"

                               DO BOT^PSGMAR3

                               DO HEADER^PSGMAR3

                               SET PSGMAROC=1

                   End DoDot:1

 +6        QUIT 

ORSET     ; order record set

 +1        IF PST["P"!P(9)=""

               QUIT 

 +2        SET PSGMFOR=""

           SET (SD,X)=$PIECE(P(2),".")

           IF X>PSGPLF

               QUIT 

           SET FD=$PIECE(P(3),".")

           SET PSGOES=""

           SET X=P(9)

           DO EN^PSGS0

           SET T=PSGS0XT

 +3        SET X=""

           IF "OB"]PST

               IF $PIECE(P(9),"^")'["@"

                   IF P(2)'>PSGPLS

                       IF P(3)'<PSGPLF

                           IF P(11)

                               IF T<1441

                                   IF T'="D"

                                       SET X=P(11)

                                       SET PSGPLC=1

 +4       IF '$TEST

               IF "OB"]PST!(PST["OV")

                   KILL PSGMAR

                   DO SETL0

                   SET (Q,X)=""

                   FOR QX=0:0

                       SET Q=$ORDER(PSGMAR(Q))

                       IF Q=""

                           QUIT 

                       SET X=X_$EXTRACT("0",2-$LENGTH(Q))_Q_"-"

 +5        SET TMSTR=X

 +6        KILL HCD,HM,I,J,PSGD,PLSD,CD,M,MID,MN,ND,ND1,OD,ST,QD1,QD2,QQ,TS,UD,WDT,WS,WS1,X,X1,X2

           QUIT 

 +7        QUIT 

SETL0     ;*** Set variable to use in ^PSGPL0 to calculate admin time.

 +1        KILL PSGMAR

           SET PSGPLC=0

 +2        SET ND1=P(4)

           SET ST=P(2)

           SET PLSD=P(3)

           SET TS=P(11)

           SET MN=T

           SET ND=P(9)

           IF $SELECT(ST'?7N1"."1N.E:1,1:PLSD'?7N1"."1N.E)

               SET PSGPLC="OI"

               QUIT 

 +3        DO ENIV^PSGPL0

 +4        QUIT 

 +5       ;

RPHINIT(RPH) ; Find initial for the person who completed the IV order.

 +1        SET RPH=$PIECE($GET(^PS(55,PSGP,"IV",+ON,4)),U,4)

 +2        IF +RPH

               SET RPH=$$DEFINIT(+RPH)

 +3        IF RPH=""