Routine: PSJORMAR

PSJORMAR ;BIR/MV-CREATE AN ARRAY FOR THE MAR LABEL. ;19 Mar 99 / 9:33 AM

 ;;5.0; INPATIENT MEDICATIONS ;**2,15,26,65**;16 DEC 97

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

 ; References to ^PSD(58.8 supported by DBIA #2283.

 ; References to ^PSI(58.1 supported by DBIA #2284.

 ; Reference to ^VA(200 is supported by DBIA #10060.

 ; Reference to ^VALM1 is supported by DBIA #10116.

MAR(DFN,ON,PT,MARLB,ACT)         ;

 ;Input

 ;  DFN     : Patient's internal entry number

 ;  ON      : Order number (ex: 53U (U/D), 14V (IV), 1000P (pending)

 ;  PT      : =1 to print patient data on the right label.

 ;          : =0 will not print the patient data

 ;  MARLB   : Array name

 ;  ACT     : Action on order or null

 ;          :NW:NEW;DC:DISCONTINUE;HD:HOLD;RL:RELEASE HOLD

 ;Output

 ;  MARLB(X): There are 5 lines print per label.  An order may contain

 ;          : multiple labels.

 NEW NODE,TYPE

 NEW C,DRG,DRGI,DRGN,DRGT,DRUGNAME,F,FIL,L,ND,P,PSGDT,PSGLAD

 NEW PSGLAGE,PSGLBID,PSGLBS5,PSGLDESC,PSGLDOB,PSGLDT

 NEW PSGLDX,PSGLFD,PSGLNF,PSGLOD,PSGLPID,PSGLPN,PSGLPR

 NEW PSGLR,PSGLRB,PSGLRN,PSGLRPH,PSGLRTN,PSGLSD,PSGLSEX

 NEW PSGLSI,PSGLSM,PSGLSSN,PSGLST,PSGLTM,PSGLTS,PSGLWD

 NEW PSGLWG,PSGLWDN,PSGLWGN,PSGLWS,PSGMARGD,PSGOES

 NEW PSGOP,PSGORD,PSGP,PSGS0XT,PSGS0Y,PSGST,PSGTOL

 NEW PSGVADR,PSIVUP,PSJCONT,PSJOPC,PSJORIFN,PST,Q,QQ,S,SD

 NEW STOP,T,TS,VA,X

 NEW PSJPON,PSJROC,PSJF,PSJLDT

 S (PSGP,PSGOP)=DFN,PSGORD=ON D ^PSGLPI

 D NOW^%DTC S PSJLDT=$E(%,1,12)

 I ON["P" S NODE(0)=$G(^PS(53.1,+ON,0)),TYPE=$P(NODE(0),U,4)

 I $G(TYPE)="F"!(ON["V") D IV Q

 S:ON["U" NODE(0)=$G(^PS(55,DFN,5,+ON,0))

 I $G(ACT)="NW" D

 .S PSJPON=$P(NODE(0),U,25) I $G(PSJPON)]"" D

 ..S PSJROC=$S(PSJPON["U":$P(^PS(55,PSGP,5,+PSJPON,0),U,27),PSJPON["V":$P(^PS(55,PSGP,"IV",+PSJPON,2),U,9),1:$P(^PS(53.1,+PSJPON,0),U,27))

 ..S PSJF=$S(PSJPON["U":"^PS(55,"_PSGP_",5,"_+PSJPON,PSJPON["V":"^PS(55,"_PSGP_",""IV"","_+PSJPON,1:"^PS(53.1,"_+PSJPON)

 ..S:$G(PSJROC)]"" $P(@(PSJF_",7)"),U,1,2)=PSJLDT_"^"_$S(PSJROC="R":"R",1:"DE")

 S PSJF=$S(ON["U":"^PS(55,"_PSGP_",5,"_+ON,1:"^PS(53.1,"_+ON)

 I $G(ACT)]""&($G(ACT)'="NW") S $P(@(PSJF_",7)"),U,1,2)=PSJLDT_"^"_$S(ACT="DC":"D",ACT="HD":"H1",1:"H0")

 D UD

IV ;

 D ^PSJORMA2,TS

UD ;Gather data for U/D order.

 ;S PSGOP=DFN,PSGORD=ON D ^PSGLPI

 ;S PSGP(0)=PSGLPN,PSSN=PSGLSSN

 I $G(NODE(0))="" D  Q

 . S MARLB(1)=PSGLPN_" "_PSGLSSN

 . S MARLB(2)=""

 . S MARLB(3)="Order #: "_ON_" does not exist."

 . S MARLB(4)="Please check."

 . S MARLB(5)=""

 S F=$S(ON["U":"^PS(55,DFN,5,+ON,",1:"^PS(53.1,+ON,")

 S NODE(2)=$G(@(F_"2)"))

 S NODE(4)=$G(@(F_"4)"))

 S NODE(7)=$G(@(F_"7)"))

 S PSGLDT=+NODE(7),PSGLR=$P(NODE(7),U,2)

 S PSGLRN=+NODE(4),PSGLRPH=$P(NODE(4),U,3)

 S PSGLOD=$E($$ENDTC^PSGMI($P(NODE(0),U,14)),1,5)

 S PSGLSD=$$BLANK^PSGMUTL(11),PSGLFD=$$BLANK^PSGMUTL(14)

 I ON["U" D

 . S PSGLSD=$$ENDTC1^PSGMI($P(NODE(2),U,2)),PSGLSD=$E(PSGLSD,1,5)_$E(PSGLSD,9,14)

 . S PSGLFD=$$ENDTC1^PSGMI($P(NODE(2),U,4))

 S PSGLST=$P(NODE(0),U,7),PST=$S(PSGLST="C"!(PSGLST="O"):PSGLST,PSGLST="OC":"OA",PSGLST="P":"OP",$P(NODE(2),"^")["PRN":"OR",1:"CR")

 ;S (PSGLST,PST)=$P(NODE(0),U,7)

 D TS^PSGMAR3($P(NODE(2),U,5))

 I $P(NODE(0),U,22) S PSGLSI="*** NOT TO BE GIVEN ***"

 E  S PSGLSI=$G(@(F_"6)"))

 I PSGLSI="",$P($G(@(F_"0)")),U,9)="P",$O(@(F_"12,0)")) S X=0 F  S X=$O(@(F_"12,"_X_")")) Q:'X  S Z=$G(^(X,0)),Y=$L(PSGLSI) S:Y+$L(Z)'>179 PSGLSI=PSGLSI_Z_" " I Y+$L(Z)>179 S PSGLSI="SEE PROVIDER COMMENTS"

 S PSGLSM=$S('$P(NODE(0),U,5):0,$P(NODE(0),U,6):1,1:2)

 N PSGNOW D NOW^%DTC S PSGNOW=% S (PSGLNF,PSGLWS)=0 F X=0:0 S X=$O(@(F_"1,"_X_")")) Q:'X!(PSGLWS)  S Y=$G(^(X,0)) I $P(Y,U,3)>PSGNOW!'$P(Y,U,3) S PSGLWS=$S($D(^PSI(58.1,"D",+Y,+PSGLWD)):1,$D(^PSD(58.8,"D",+Y,+PSGLWD)):1,1:0)

 S:'PSGLRN PSGLRN="_____" I PSGLRN,$D(^VA(200,+PSGLRN,0))#2 S X=^(0),X=$S($P(X,U,2)]"":$P(X,U,2),1:$P(X,U)),PSGLRN=$S(X'[",":X,1:$E(X,$F(X,","))_$E(X))

 S:'PSGLRPH PSGLRPH="_____" I PSGLRPH,$D(^VA(200,+PSGLRPH,0))#2 S X=^(0),X=$S($P(X,U,2)]"":$P(X,U,2),1:$P(X,U)),PSGLRPH=$S(X'[",":X,1:$E(X,$F(X,","))_$E(X))

 D MARLB^PSJORMA1(37)

 S P(9)=$P(NODE(0),U,9),P(3)=$P(NODE(2),U,4)

TS ;Attach amdin times to the label.

 ;D NOW^%DTC S PSGDT=$E(%,1,12),PSGLFD=$P(NODE(2),U,4)

 D NOW^%DTC S PSGDT=$E(%,1,12)

 I P(3)]"",$E(P(3),1,12)'>PSGDT D

 . F X=1:1:5 S TS(X)="****"

 . S TS(3)=$S(P(9)["D":"DC'D",1:"EX'D"),TS(0)=5

 F X=0:0 S X=$O(MARLB(X)) Q:'X  S MARLB(X)=$$SETSTR^VALM1("|"_$G(TS(X)),MARLB(X),43,9)

 D:$G(PT) PT

PT ;Hook up patient info to label

 ;S MARLB(1)=$$SETSTR^VALM1(PSGLPN,MARLB(1),52,87)

 S MARLB(1)=MARLB(1)_PSGLPN

 S X=$S(PSGLRB]"":PSGLRB,1:"*NF*")

 S MARLB(1)=$$SETSTR^VALM1(X,MARLB(1),(97-$L(X)),$L(X))

 ;S MARLB(2)=$$SETSTR^VALM1(PSGLSSN,MARLB(2),52,17)

 S MARLB(2)=MARLB(2)_PSGLSSN

 S MARLB(2)=$$SETSTR^VALM1(PSGLDOB_"  ("_PSGLAGE_")",MARLB(2),70,14)

 S MARLB(2)=$$SETSTR^VALM1($S(PSGLTM]"":PSGLTM,1:"NOT FOUND"),MARLB(2),88,15)

 S MARLB(3)=MARLB(3)_PSGLSEX

 S MARLB(3)=$$SETSTR^VALM1("DX: "_PSGLDX,MARLB(3),65,($L(PSGLDX)+4))

 S:PSGLDT MARLB(4)=MARLB(4)_$$ENDTC^PSGMI(PSGLDT)

 S Y=PSGLR,X=$S(Y="NR":"RENEWAL ",Y="N":"NEW ",1:"")_"ORDER"

 S Y=X_$S(Y="E":" EDITED",Y="DE":" DC'ED (EDIT)",Y["D":" DISCONTINUED",Y="H1":" ON HOLD",Y="H0":" OFF OF HOLD",Y="RE":" REINSTATED",1:"")

 ;I PSGLFD]"",(PSGLFD'>PSGDT),(PSGLR'["D") S Y=Y_" (EXPIRED)"

 I P(3)]"",(P(3)'>PSGDT),(PSGLR'["D") S Y=Y_" (EXPIRED)"

 I Y="ORDER" S Y=""

 ;;S:ON["P" Y=""

 S MARLB(4)=$$SETSTR^VALM1(Y,MARLB(4),(97-$L(Y)),$L(Y))

 S MARLB(5)=MARLB(5)_$S(PSGLWGN]"":$E(PSGLWGN,1,21),1:"NOT FOUND")

 S X=$S(PSGLWDN]"":$E(PSGLWDN,1,21),1:"NOT FOUND")

 S MARLB(5)=$$SETSTR^VALM1(X,MARLB(5),(97-$L(X)),$L(X))

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJORMAR   5701     printed  Feb 18, 2025@23:34:42                                                                                                                                                                                                    Page 2

PSJORMAR  ;BIR/MV-CREATE AN ARRAY FOR THE MAR LABEL. ;19 Mar 99 / 9:33 AM

 +1       ;;5.0; INPATIENT MEDICATIONS ;**2,15,26,65**;16 DEC 97

 +2       ;

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

 +4       ; References to ^PSD(58.8 supported by DBIA #2283.

 +5       ; References to ^PSI(58.1 supported by DBIA #2284.

 +6       ; Reference to ^VA(200 is supported by DBIA #10060.

 +7       ; Reference to ^VALM1 is supported by DBIA #10116.

 +8       ;

MAR(DFN,ON,PT,MARLB,ACT) ;

 +1       ;Input

 +2       ;  DFN     : Patient's internal entry number

 +3       ;  ON      : Order number (ex: 53U (U/D), 14V (IV), 1000P (pending)

 +4       ;  PT      : =1 to print patient data on the right label.

 +5       ;          : =0 will not print the patient data

 +6       ;  MARLB   : Array name

 +7       ;  ACT     : Action on order or null

 +8       ;          :NW:NEW;DC:DISCONTINUE;HD:HOLD;RL:RELEASE HOLD

 +9       ;Output

 +10      ;  MARLB(X): There are 5 lines print per label.  An order may contain

 +11      ;          : multiple labels.

 +12      ;

 +13       NEW NODE,TYPE

 +14       NEW C,DRG,DRGI,DRGN,DRGT,DRUGNAME,F,FIL,L,ND,P,PSGDT,PSGLAD

 +15       NEW PSGLAGE,PSGLBID,PSGLBS5,PSGLDESC,PSGLDOB,PSGLDT

 +16       NEW PSGLDX,PSGLFD,PSGLNF,PSGLOD,PSGLPID,PSGLPN,PSGLPR

 +17       NEW PSGLR,PSGLRB,PSGLRN,PSGLRPH,PSGLRTN,PSGLSD,PSGLSEX

 +18       NEW PSGLSI,PSGLSM,PSGLSSN,PSGLST,PSGLTM,PSGLTS,PSGLWD

 +19       NEW PSGLWG,PSGLWDN,PSGLWGN,PSGLWS,PSGMARGD,PSGOES

 +20       NEW PSGOP,PSGORD,PSGP,PSGS0XT,PSGS0Y,PSGST,PSGTOL

 +21       NEW PSGVADR,PSIVUP,PSJCONT,PSJOPC,PSJORIFN,PST,Q,QQ,S,SD

 +22       NEW STOP,T,TS,VA,X

 +23       NEW PSJPON,PSJROC,PSJF,PSJLDT

 +24       SET (PSGP,PSGOP)=DFN

           SET PSGORD=ON

           DO ^PSGLPI

 +25       DO NOW^%DTC

           SET PSJLDT=$EXTRACT(%,1,12)

 +26       IF ON["P"

               SET NODE(0)=$GET(^PS(53.1,+ON,0))

               SET TYPE=$PIECE(NODE(0),U,4)

 +27       IF $GET(TYPE)="F"!(ON["V")

               DO IV

               QUIT

 +28       if ON["U"

               SET NODE(0)=$GET(^PS(55,DFN,5,+ON,0))

 +29       IF $GET(ACT)="NW"

               Begin DoDot:1

 +30               SET PSJPON=$PIECE(NODE(0),U,25)

                   IF $GET(PSJPON)]""

                       Begin DoDot:2

 +31                       SET PSJROC=$SELECT(PSJPON["U":$PIECE(^PS(55,PSGP,5,+PSJPON,0),U,27),PSJPON["V":$PIECE(^PS(55,PSGP,"IV",+PSJPON,2),U,9),1:$PIECE(^PS(53.1,+PSJPON,0),U,27))

 +32                       SET PSJF=$SELECT(PSJPON["U":"^PS(55,"_PSGP_",5,"_+PSJPON,PSJPON["V":"^PS(55,"_PSGP_",""IV"","_+PSJPON,1:"^PS(53.1,"_+PSJPON)

 +33                       if $GET(PSJROC)]""

                               SET $PIECE(@(PSJF_",7)"),U,1,2)=PSJLDT_"^"_$SELECT(PSJROC="R":"R",1:"DE")

                       End DoDot:2

               End DoDot:1

 +34       SET PSJF=$SELECT(ON["U":"^PS(55,"_PSGP_",5,"_+ON,1:"^PS(53.1,"_+ON)

 +35       IF $GET(ACT)]""&($GET(ACT)'="NW")

               SET $PIECE(@(PSJF_",7)"),U,1,2)=PSJLDT_"^"_$SELECT(ACT="DC":"D",ACT="HD":"H1",1:"H0")

 +36       DO UD

 +37       QUIT

IV        ;

 +1        DO ^PSJORMA2

           DO TS

 +2        QUIT

UD        ;Gather data for U/D order.

 +1       ;S PSGOP=DFN,PSGORD=ON D ^PSGLPI

 +2       ;S PSGP(0)=PSGLPN,PSSN=PSGLSSN

 +3        IF $GET(NODE(0))=""

               Begin DoDot:1

 +4                SET MARLB(1)=PSGLPN_" "_PSGLSSN

 +5                SET MARLB(2)=""

 +6                SET MARLB(3)="Order #: "_ON_" does not exist."

 +7                SET MARLB(4)="Please check."

 +8                SET MARLB(5)=""

               End DoDot:1

               QUIT

 +9        SET F=$SELECT(ON["U":"^PS(55,DFN,5,+ON,",1:"^PS(53.1,+ON,")

 +10       SET NODE(2)=$GET(@(F_"2)"))

 +11       SET NODE(4)=$GET(@(F_"4)"))

 +12       SET NODE(7)=$GET(@(F_"7)"))

 +13       SET PSGLDT=+NODE(7)

           SET PSGLR=$PIECE(NODE(7),U,2)

 +14       SET PSGLRN=+NODE(4)

           SET PSGLRPH=$PIECE(NODE(4),U,3)

 +15       SET PSGLOD=$EXTRACT($$ENDTC^PSGMI($PIECE(NODE(0),U,14)),1,5)

 +16       SET PSGLSD=$$BLANK^PSGMUTL(11)

           SET PSGLFD=$$BLANK^PSGMUTL(14)

 +17       IF ON["U"

               Begin DoDot:1

 +18               SET PSGLSD=$$ENDTC1^PSGMI($PIECE(NODE(2),U,2))

                   SET PSGLSD=$EXTRACT(PSGLSD,1,5)_$EXTRACT(PSGLSD,9,14)

 +19               SET PSGLFD=$$ENDTC1^PSGMI($PIECE(NODE(2),U,4))

               End DoDot:1

 +20       SET PSGLST=$PIECE(NODE(0),U,7)

           SET PST=$SELECT(PSGLST="C"!(PSGLST="O"):PSGLST,PSGLST="OC":"OA",PSGLST="P":"OP",$PIECE(NODE(2),"^")["PRN":"OR",1:"CR")

 +21      ;S (PSGLST,PST)=$P(NODE(0),U,7)

 +22       DO TS^PSGMAR3($PIECE(NODE(2),U,5))

 +23       IF $PIECE(NODE(0),U,22)

               SET PSGLSI="*** NOT TO BE GIVEN ***"

 +24      IF '$TEST

               SET PSGLSI=$GET(@(F_"6)"))

 +25       IF PSGLSI=""

               IF $PIECE($GET(@(F_"0)")),U,9)="P"

                   IF $ORDER(@(F_"12,0)"))

                       SET X=0

FOR

                           SET X=$ORDER(@(F_"12,"_X_")"))

                           if 'X

                               QUIT

                           SET Z=$GET(^(X,0))

                           SET Y=$LENGTH(PSGLSI)

                           if Y+$LENGTH(Z)'>179

                               SET PSGLSI=PSGLSI_Z_" "

                           IF Y+$LENGTH(Z)>179

                               SET PSGLSI="SEE PROVIDER COMMENTS"

 +26       SET PSGLSM=$SELECT('$PIECE(NODE(0),U,5):0,$PIECE(NODE(0),U,6):1,1:2)

 +27       NEW PSGNOW

           DO NOW^%DTC

           SET PSGNOW=%

           SET (PSGLNF,PSGLWS)=0

           FOR X=0:0

               SET X=$ORDER(@(F_"1,"_X_")"))

               if 'X!(PSGLWS)

                   QUIT

               SET Y=$GET(^(X,0))

               IF $PIECE(Y,U,3)>PSGNOW!'$PIECE(Y,U,3)

                   SET PSGLWS=$SELECT($DATA(^PSI(58.1,"D",+Y,+PSGLWD)):1,$DATA(^PSD(58.8,"D",+Y,+PSGLWD)):1,1:0)

 +28       if 'PSGLRN

               SET PSGLRN="_____"

           IF PSGLRN

               IF $DATA(^VA(200,+PSGLRN,0))#2

                   SET X=^(0)

                   SET X=$SELECT($PIECE(X,U,2)]"":$PIECE(X,U,2),1:$PIECE(X,U))

                   SET PSGLRN=$SELECT(X'[",":X,1:$EXTRACT(X,$FIND(X,","))_$EXTRACT(X))

 +29       if 'PSGLRPH

               SET PSGLRPH="_____"

           IF PSGLRPH

               IF $DATA(^VA(200,+PSGLRPH,0))#2

                   SET X=^(0)

                   SET X=$SELECT($PIECE(X,U,2)]"":$PIECE(X,U,2),1:$PIECE(X,U))

                   SET PSGLRPH=$SELECT(X'[",":X,1:$EXTRACT(X,$FIND(X,","))_$EXTRACT(X))

 +30       DO MARLB^PSJORMA1(37)

 +31       SET P(9)=$PIECE(NODE(0),U,9)

           SET P(3)=$PIECE(NODE(2),U,4)

 +32      ;

TS        ;Attach amdin times to the label.

 +1       ;D NOW^%DTC S PSGDT=$E(%,1,12),PSGLFD=$P(NODE(2),U,4)

 +2        DO NOW^%DTC

           SET PSGDT=$EXTRACT(%,1,12)

 +3        IF P(3)]""

               IF $EXTRACT(P(3),1,12)'>PSGDT

                   Begin DoDot:1

 +4                    FOR X=1:1:5

                           SET TS(X)="****"

 +5                    SET TS(3)=$SELECT(P(9)["D":"DC'D",1:"EX'D")

                       SET TS(0)=5

                   End DoDot:1

 +6        FOR X=0:0

               SET X=$ORDER(MARLB(X))

               if 'X

                   QUIT

               SET MARLB(X)=$$SETSTR^VALM1("|"_$GET(TS(X)),MARLB(X),43,9)

 +7        if $GET(PT)

               DO PT

 +8        QUIT

 +9       ;

PT        ;Hook up patient info to label

 +1       ;S MARLB(1)=$$SETSTR^VALM1(PSGLPN,MARLB(1),52,87)

 +2        SET MARLB(1)=MARLB(1)_PSGLPN

 +3        SET X=$SELECT(PSGLRB]"":PSGLRB,1:"*NF*")

 +4        SET MARLB(1)=$$SETSTR^VALM1(X,MARLB(1),(97-$LENGTH(X)),$LENGTH(X))

 +5       ;S MARLB(2)=$$SETSTR^VALM1(PSGLSSN,MARLB(2),52,17)

 +6        SET MARLB(2)=MARLB(2)_PSGLSSN

 +7        SET MARLB(2)=$$SETSTR^VALM1(PSGLDOB_"  ("_PSGLAGE_")",MARLB(2),70,14)

 +8        SET MARLB(2)=$$SETSTR^VALM1($SELECT(PSGLTM]"":PSGLTM,1:"NOT FOUND"),MARLB(2),88,15)

 +9        SET MARLB(3)=MARLB(3)_PSGLSEX

 +10       SET MARLB(3)=$$SETSTR^VALM1("DX: "_PSGLDX,MARLB(3),65,($LENGTH(PSGLDX)+4))

 +11       if PSGLDT

               SET MARLB(4)=MARLB(4)_$$ENDTC^PSGMI(PSGLDT)

 +12       SET Y=PSGLR

           SET X=$SELECT(Y="NR":"RENEWAL ",Y="N":"NEW ",1:"")_"ORDER"

 +13       SET Y=X_$SELECT(Y="E":" EDITED",Y="DE":" DC'ED (EDIT)",Y["D":" DISCONTINUED",Y="H1":" ON HOLD",Y="H0":" OFF OF HOLD",Y="RE":" REINSTATED",1:"")

 +14      ;I PSGLFD]"",(PSGLFD'>PSGDT),(PSGLR'["D") S Y=Y_" (EXPIRED)"

 +15       IF P(3)]""

               IF (P(3)'>PSGDT)

                   IF (PSGLR'["D")

                       SET Y=Y_" (EXPIRED)"

 +16       IF Y="ORDER"

               SET Y=""

 +17      ;;S:ON["P" Y=""

 +18       SET MARLB(4)=$$SETSTR^VALM1(Y,MARLB(4),(97-$LENGTH(Y)),$LENGTH(Y))

 +19       SET MARLB(5)=MARLB(5)_$SELECT(PSGLWGN]"":$EXTRACT(PSGLWGN,1,21),1:"NOT FOUND")

 +20       SET X=$SELECT(PSGLWDN]"":$EXTRACT(PSGLWDN,1,21),1:"NOT FOUND")

 +21       SET MARLB(5)=$$SETSTR^VALM1(X,MARLB(5),(97-$LENGTH(X)),$LENGTH(X))

 +22       QUIT

PSJORMAR.m