PSJORMA2.m

PSJORMA2 ;BIR/MV-COLLECT DATA FOR ACTIVE IV AND FLUID PENDINGS ; 3/23/10 2:42pm

 ;;5.0;INPATIENT MEDICATIONS ;**2,15,21,26,58,237,275**;16 DEC 97;Build 157

 ;

 ; References to ^PS(52.7 supported by DBIA #2173

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

 ; Reference to SETSTR^VALM1 supported by DBIA #10116

 ;

PRT ;Get IV nodes.

 K P,DRG,PSGLRN,PSGMARTS,PSGMARGD,PSGLFFD,TS N ON55 S TS=1,PSGMARGD=""

 I ON["V" D

 .I '$G(DUZ) N DUZ S DUZ=$J

 .I '$G(PSJSYSP) N PSJSYSP S PSJSYSP=$J

 .D GT55^PSIVORFB

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

 I $G(ACT)="NW" D

 .S P("OLDON")=$S(ON["P":$P($G(^PS(53.1,+ON,0)),U,25),1:$P($G(^PS(55,DFN,"IV",+ON,2)),U,5))

 .I $G(P("OLDON"))]"" S PSJROC=$S(P("OLDON")["V":$P(^PS(55,DFN,"IV",+P("OLDON"),2),U,8),1:$P(^PS(53.1,+P("OLDON"),0),U,27)),PSJF=$S(P("OLDON")["V":"^PS(55,"_DFN_",""IV"","_+P("OLDON"),1:"^PS(53.1,"_+P("OLDON")) D

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

 S PSJF=$S(ON["V":"^PS(55,"_DFN_",""IV"","_+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")

 S PSGLR=$S(ON["P":$P($G(^PS(53.1,+ON,7)),U,2),1:$P($G(^PS(55,DFN,"IV",+ON,7)),U,2))

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

 D:P(9)]"" OS S PSGLSD=P(2),PSGLFD=P(3)

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

 D INITOPI

 I PSGST="O",(P(2)="") S PSGST=""

 NEW NAMENEED,NEED,X S NAMENEED=0

 ;D LNNEED^PSGMIV,PRTIV

 D PRTIV

 Q

 ;

OS ; Define admin times.

 ;* S FD=P(3),PSGOES="",X=P(9),SD=P(2) D EN^PSGS0 S T=PSGS0XT

 S (FD,PSGMARFD)=P(3),PSGOES="",X=P(9),(SD,PSGMARSD)=P(2) D EN^PSGS0 S T=PSGS0XT

 S QQ="" I PSGST["C" D DTS^PSGMMAR0(P(9)) S SD=$P(SD,"."),QQ="" F X=0:0 S X=$O(PSGD(X)) Q:'X  S QQ=QQ_$S(X<SD:"",X>FD:"",'S:$P(PSGD(X),U),$D(S(X)):$P(PSGD(X),U),1:"")

 K PSGMARFD,PSGMARSD

 I T="D",P(11)="" S P(11)=$E($P(P(2),".",2)_"0000",1,4)

 S PSGMARTS=P(11),PSGMARGD=QQ

 K TS D TS^PSGMAR3(P(11))

 Q

 ;

PRTIV ; Set up order info on IV label.

 S MARLB(1)=$E(P("LOG"),1,5)_" |"

 I ON["P",+$G(^PS(53.1,+ON,4)) S MARLB(1)=MARLB(1)_"P E N D I N G"

 E  S MARLB(1)=MARLB(1)_$E(P(2),1,5)_$E(P(2),9,14),X=$S(ON["P":"",P(3)=1:"********",1:$$ENDTC1^PSGMI(P(3))),MARLB(1)=$$SETSTR^VALM1(" |"_X,MARLB(1),19,16)

 S MARLB(1)=$$SETSTR^VALM1("("_PSGLBS5_")",MARLB(1),36,7)

 NEW NAME S L=2

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

 . S MARLB(L)=NAME(Y) S:L=2 MARLB(L)=$$SETSTR^VALM1(PSGST,MARLB(L),42,1) D L(1)

 S:$G(DRG("SOL",0)) MARLB(L)="in " NEW PSJPRT2

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

 . F Y=0:0 S Y=$O(NAME(Y)) Q:'Y  S:(Y>1) L=L+1 S MARLB(L)=$$SETSTR^VALM1(NAME(Y),$G(MARLB(L)),4,$L(NAME(Y))) D L(1)

 . S PSJPRT2=$P(^PS(52.7,+DRG("SOL",X),0),U,4) I PSJPRT2]"" S:(Y>1) L=L+1 S MARLB(L)="       "_PSJPRT2 D L(1)

 S MARLB(L)=$P(P("MR"),U,2)_" "_P(9)_" "_P(8)

 ;I P(4)="C",'(L#4),P("OPI")="" S L=L+1,MARLB(L)=$G(MARLB(L))_"*CAUTION-CHEMOTHERAPY*" S L=L+1 Q

 I P(4)="C",'(L#4),P("OPI")="" D L(1) S MARLB(L)=$G(MARLB(L))_"*CAUTION-CHEMOTHERAPY*" D L(1)

 I P(4)'="C",(P("OPI")="") S L=L+1

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

 . F Y=1:1:$L($P(P("OPI"),"^")," ") D:$L($P($P(P("OPI"),"^")," ",Y)_"  ")+$L($G(MARLB(L)))>42 L(1) S MARLB(L)=$G(MARLB(L))_$P($P(P("OPI"),"^")," ",Y)_" " ;**PSJ*5.0*237-Prevent sentence cutoff

 . S L=L+1

 I (L#5)>0 S X=0 F  Q:X  D

 . D L(0) S MARLB(L)="",L=L+1

 . I TS,(L>TS),'(L#5) S X=1 Q

 . I TS=0,'(L#5) S X=1 Q

 S MARLB(L)=$$SETSTR^VALM1("RPH: "_PSGLRPH,$G(MARLB(L)),23,10)

 S MARLB(L)=$$SETSTR^VALM1("RN: "_PSGLRN,$G(MARLB(L)),33,9)

 Q

 ;

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

 S L=L+X

 I L#5=0 S MARLB(L)="See next label for continuation",L=L+1

 Q

INITOPI ;* Set nurse's initial and the other print info.

 D RPHINIT^PSGMIV(.PSGLRPH)

 S PSGLRN="_____"

 S:ON["P" PSGLRN=+$G(^PS(53.1,+ON,4)) S:ON["V" PSGLRN=+$G(^PS(55,DFN,"IV",+ON,4))

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

 S:$G(PSGLRN)=0 PSGLRN="_____"

 I ON["P" D

 . I P("OPI")="",$O(^PS(53.1,+ON,12,0)) S X=0 F  S X=$O(^PS(53.1,+ON,12,X)) Q:'X  S Z=$G(^(X,0)),Y=$L(P("OPI")) S:Y+$L(Z)'>179 P("OPI")=P("OPI")_Z_" " I Y+$L(Z)>179 S P("OPI")="SEE PROVIDER COMMENTS"

 . S PSGST=""

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSJORMA2   4404     printed  Feb 18, 2025@23:34:41                                                                                                                                                                                                    Page 2

PSJORMA2  ;BIR/MV-COLLECT DATA FOR ACTIVE IV AND FLUID PENDINGS ; 3/23/10 2:42pm

 +1       ;;5.0;INPATIENT MEDICATIONS ;**2,15,21,26,58,237,275**;16 DEC 97;Build 157

 +2       ;

 +3       ; References to ^PS(52.7 supported by DBIA #2173

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

 +5       ; Reference to SETSTR^VALM1 supported by DBIA #10116

 +6       ;

PRT       ;Get IV nodes.

 +1        KILL P,DRG,PSGLRN,PSGMARTS,PSGMARGD,PSGLFFD,TS

           NEW ON55

           SET TS=1

           SET PSGMARGD=""

 +2        IF ON["V"

               Begin DoDot:1

 +3                IF '$GET(DUZ)

                       NEW DUZ

                       SET DUZ=$JOB

 +4                IF '$GET(PSJSYSP)

                       NEW PSJSYSP

                       SET PSJSYSP=$JOB

 +5                DO GT55^PSIVORFB

               End DoDot:1

 +6        IF ON["P"

               DO GT531^PSIVORFA(DFN,ON,1)

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

               Begin DoDot:1

 +8                SET P("OLDON")=$SELECT(ON["P":$PIECE($GET(^PS(53.1,+ON,0)),U,25),1:$PIECE($GET(^PS(55,DFN,"IV",+ON,2)),U,5))

 +9                IF $GET(P("OLDON"))]""

                       SET PSJROC=$SELECT(P("OLDON")["V":$PIECE(^PS(55,DFN,"IV",+P("OLDON"),2),U,8),1:$PIECE(^PS(53.1,+P("OLDON"),0),U,27))

                       SET PSJF=$SELECT(P("OLDON")["V":"^PS(55,"_DFN_",""IV"","_+P("OLDON"),1:"^PS(53.1,"_+P("OLDON"))

                       Begin DoDot:2

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

                       End DoDot:2

               End DoDot:1

 +11       SET PSJF=$SELECT(ON["V":"^PS(55,"_DFN_",""IV"","_+ON,1:"^PS(53.1,"_+ON)

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

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

 +13       SET PSGLR=$SELECT(ON["P":$PIECE($GET(^PS(53.1,+ON,7)),U,2),1:$PIECE($GET(^PS(55,DFN,"IV",+ON,7)),U,2))

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

           IF PST=""

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

 +15       if P(9)]""

               DO OS

           SET PSGLSD=P(2)

           SET PSGLFD=P(3)

 +16       FOR X="LOG",2

               if P(X)

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

 +17       DO INITOPI

 +18       IF PSGST="O"

               IF (P(2)="")

                   SET PSGST=""

 +19       NEW NAMENEED,NEED,X

           SET NAMENEED=0

 +20      ;D LNNEED^PSGMIV,PRTIV

 +21       DO PRTIV

 +22       QUIT 

 +23      ;

OS        ; Define admin times.

 +1       ;* S FD=P(3),PSGOES="",X=P(9),SD=P(2) D EN^PSGS0 S T=PSGS0XT

 +2        SET (FD,PSGMARFD)=P(3)

           SET PSGOES=""

           SET X=P(9)

           SET (SD,PSGMARSD)=P(2)

           DO EN^PSGS0

           SET T=PSGS0XT

 +3        SET QQ=""

           IF PSGST["C"

               DO DTS^PSGMMAR0(P(9))

               SET SD=$PIECE(SD,".")

               SET QQ=""

               FOR X=0:0

                   SET X=$ORDER(PSGD(X))

                   if 'X

                       QUIT 

                   SET QQ=QQ_$SELECT(X<SD:"",X>FD:"",'S:$PIECE(PSGD(X),U),$DATA(S(X)):$PIECE(PSGD(X),U),1:"")

 +4        KILL PSGMARFD,PSGMARSD

 +5        IF T="D"

               IF P(11)=""

                   SET P(11)=$EXTRACT($PIECE(P(2),".",2)_"0000",1,4)

 +6        SET PSGMARTS=P(11)

           SET PSGMARGD=QQ

 +7        KILL TS

           DO TS^PSGMAR3(P(11))

 +8        QUIT 

 +9       ;

PRTIV     ; Set up order info on IV label.

 +1        SET MARLB(1)=$EXTRACT(P("LOG"),1,5)_" |"

 +2        IF ON["P"

               IF +$GET(^PS(53.1,+ON,4))

                   SET MARLB(1)=MARLB(1)_"P E N D I N G"

 +3       IF '$TEST

               SET MARLB(1)=MARLB(1)_$EXTRACT(P(2),1,5)_$EXTRACT(P(2),9,14)

               SET X=$SELECT(ON["P":"",P(3)=1:"********",1:$$ENDTC1^PSGMI(P(3)))

               SET MARLB(1)=$$SETSTR^VALM1(" |"_X,MARLB(1),19,16)

 +4        SET MARLB(1)=$$SETSTR^VALM1("("_PSGLBS5_")",MARLB(1),36,7)

 +5        NEW NAME

           SET L=2

 +6        FOR X=0:0

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

               if 'X

                   QUIT 

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

               FOR Y=0:0

                   SET Y=$ORDER(NAME(Y))

                   if 'Y

                       QUIT 

                   Begin DoDot:1

 +7                    SET MARLB(L)=NAME(Y)

                       if L=2

                           SET MARLB(L)=$$SETSTR^VALM1(PSGST,MARLB(L),42,1)

                       DO L(1)

                   End DoDot:1

 +8        if $GET(DRG("SOL",0))

               SET MARLB(L)="in "

           NEW PSJPRT2

 +9        FOR X=0:0

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

               if 'X

                   QUIT 

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

               Begin DoDot:1

 +10               FOR Y=0:0

                       SET Y=$ORDER(NAME(Y))

                       if 'Y

                           QUIT 

                       if (Y>1)

                           SET L=L+1

                       SET MARLB(L)=$$SETSTR^VALM1(NAME(Y),$GET(MARLB(L)),4,$LENGTH(NAME(Y)))

                       DO L(1)

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

                   IF PSJPRT2]""

                       if (Y>1)

                           SET L=L+1

                       SET MARLB(L)="       "_PSJPRT2

                       DO L(1)

               End DoDot:1

 +12       SET MARLB(L)=$PIECE(P("MR"),U,2)_" "_P(9)_" "_P(8)

 +13      ;I P(4)="C",'(L#4),P("OPI")="" S L=L+1,MARLB(L)=$G(MARLB(L))_"*CAUTION-CHEMOTHERAPY*" S L=L+1 Q

 +14       IF P(4)="C"

               IF '(L#4)

                   IF P("OPI")=""

                       DO L(1)

                       SET MARLB(L)=$GET(MARLB(L))_"*CAUTION-CHEMOTHERAPY*"

                       DO L(1)

 +15       IF P(4)'="C"

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

                   SET L=L+1

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

               DO L(1)

               Begin DoDot:1

 +17      ;**PSJ*5.0*237-Prevent sentence cutoff

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

                       if $LENGTH($PIECE($PIECE(P("OPI"),"^")," ",Y)_"  ")+$LENGTH($GET(MARLB(L)))>42

                           DO L(1)

                       SET MARLB(L)=$GET(MARLB(L))_$PIECE($PIECE(P("OPI"),"^")," ",Y)_" "

 +18               SET L=L+1

               End DoDot:1

 +19       IF (L#5)>0

               SET X=0

               FOR 

                   if X

                       QUIT 

                   Begin DoDot:1

 +20                   DO L(0)

                       SET MARLB(L)=""

                       SET L=L+1

 +21                   IF TS

                           IF (L>TS)

                               IF '(L#5)

                                   SET X=1

                                   QUIT 

 +22                   IF TS=0

                           IF '(L#5)

                               SET X=1

                               QUIT 

                   End DoDot:1

 +23       SET MARLB(L)=$$SETSTR^VALM1("RPH: "_PSGLRPH,$GET(MARLB(L)),23,10)

 +24       SET MARLB(L)=$$SETSTR^VALM1("RN: "_PSGLRN,$GET(MARLB(L)),33,9)

 +25       QUIT 

 +26      ;

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

 +1        SET L=L+X

 +2        IF L#5=0

               SET MARLB(L)="See next label for continuation"

               SET L=L+1

 +3        QUIT 

INITOPI   ;* Set nurse's initial and the other print info.

 +1        DO RPHINIT^PSGMIV(.PSGLRPH)

 +2        SET PSGLRN="_____"

 +3        if ON["P"

               SET PSGLRN=+$GET(^PS(53.1,+ON,4))

           if ON["V"

               SET PSGLRN=+$GET(^PS(55,DFN,"IV",+ON,4))

 +4        IF PSGLRN

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

                   SET X=^(0)

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

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

 +5        if $GET(PSGLRN)=0

               SET PSGLRN="_____"

 +6        IF ON["P"

               Begin DoDot:1

 +7                IF P("OPI")=""

                       IF $ORDER(^PS(53.1,+ON,12,0))

                           SET X=0

                           FOR 

                               SET X=$ORDER(^PS(53.1,+ON,12,X))

                               if 'X

                                   QUIT 

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

                               SET Y=$LENGTH(P("OPI"))

                               if Y+$LENGTH(Z)'>179

                                   SET P("OPI")=P("OPI")_Z_" "

                               IF Y+$LENGTH(Z)>179

                                   SET P("OPI")="SEE PROVIDER COMMENTS"

 +8                SET PSGST=""

               End DoDot:1

 +9        QUIT