FHCTF5.m

FHCTF5 ; HIOFO/REL/FAI - Check Inpatients for Monitors ;08/29/06  14:43

 ;;5.5;Dietetics;**4,8**;Jan 28, 2005;Build 28

 ;3/14/07 - patch 8 adds the nutrition assessment alert.

 D NOW^%DTC S NOW=% D CLR

 S FHEDT=$P(NOW,".")

 F WRD=0:0 S WRD=$O(^FH(119.6,WRD)) Q:WRD<1  S FHDUZ=$P($G(^(WRD,0)),"^",2) F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",WRD,FHDFN)) Q:FHDFN'>0  S ADM=$G(^FHPT("AW",WRD,FHDFN)) D PAT

 D P5

 K %,A1,A2,ADM,BMI,CLR,DA,DD,DFN,DIC,DTE,FHDUZ,FHOR,FHORD,FHTF

 K GMRVSTR,HT,L,LST,MONIFN,MONTX,N,NOW,PX,STOP,TF,WRD,WT,X,X0,Y

 K I,FHTMO,FHTFLG,FHEDT,FHTICK,FHTDFN,FHTDT1,FHWTDT,FHHTDT,WARD,FHGMDT

 K A,A0,AGE,BID,DEAD,FDA,FHAGE,FHBID,FHCLIN,FHDFN,FHI,FHI115,FHJ,FHJDAT,FHDFN

 K FHPTNM,FHPCZN,FHSEX,FHSSN,FHHDAT,FILE,HTM,IEN,IEN200,NAM,PID,SEX

 Q

PAT ;; Check a patient

 D PATNAME^FHOMUTL I DFN="" Q

 S Y=^DPT(DFN,0),NAM=$P(Y,"^",1),SEX=$P(Y,"^",2),DOB=$P(Y,"^",3)

 S AGE="" I DOB'="" S AGE=$E(NOW,1,3)-$E(DOB,1,3)-($E(NOW,4,7)<$E(DOB,4,7))

 S DEAD=$P($G(^DPT(DFN,.35)),"^",1) Q:DEAD'=""

 D ALRT^FHASM2A    ;creates alert for nutrition assessment(follow-up dt & food/drug interaction.

 ;

P0 ; Calculate BMI

 S GMRVSTR="WT" D EN6^GMRVUTL S WT=$P(X,"^",8),FHWTDT=$P(X,"^",1)

 S GMRVSTR="HT" D EN6^GMRVUTL S HT=$P(X,"^",8),FHHTDT=$P(X,"^",1)

 S FHGMDT=$S(FHWTDT>FHHTDT:FHWTDT,FHHTDT>FHWTDT:FHHTDT,1:FHWTDT)

 S BMI="" I WT,HT S A2=HT*.0254,BMI=+$J(WT/2.2/(A2*A2),0,1)

 I $G(BMI)=""!($G(BMI)'<18.5) G P1

 S MONTX="Monitor: BMI < 18.5",DTE=NOW

 S N=$O(^FHPT(FHDFN,"A",ADM,"MO","B",MONTX,""),-1) I 'N,(FHGMDT>(FHEDT-7)) D FIL G P1

 I 'N G P1

 ; Check if been 30 days

 S LST=$P($G(^FHPT(FHDFN,"A",ADM,"MO",N,0)),"^",2)

 S X=$$FMDIFF^XLFDT(DTE,LST) I (X>30) D FIL

P1 ; Check for current Tubefeeding

 S TF=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",4) I 'TF G P2

 S MONTX="Monitor: On Tubefeeding",DTE=NOW

 S N=$O(^FHPT(FHDFN,"A",ADM,"MO","B",MONTX,""),-1) I 'N D FIL G P2

 ; Check if been 7 days

 S LST=$P($G(^FHPT(FHDFN,"A",ADM,"MO",N,0)),"^",2)

 S X=$$FMDIFF^XLFDT(DTE,LST) I X>7 D FIL

P2 ; Check for Hyperals

 S MONTX="",DTE=NOW

 D PSS435^PSS55(DFN,,"FHIV") F DA=0:0 S DA=$O(^TMP($J,"FHIV",DA)) Q:DA<1  D

 .S (X0,HTM)=$P($G(^TMP($J,"FHIV",DA,.02)),"^",2) I X0>NOW Q

 .S MONTX="Monitor: On Hyperals" D FIL Q

 ;

P3 ; Check for Serum Albumin

 S MONTX="",PX=6 D LAB^FHASM4 I $D(^TMP($J,"LRTST")) D

 .F L=0:0 S L=$O(^TMP($J,"LRTST",L)) Q:L<1  S Y=$TR($P(^(L),"^",6)," ","") I Y'?1A.E,Y<2.8 S MONTX="Monitor: Albumin < 2.8",DTE=$P(^(L),"^",7)

 I MONTX="" G P4

 S N=$O(^FHPT(FHDFN,"A",ADM,"MO","B",MONTX,""),-1)

 ;process new Albumin if old test date is within 7 days.

 I 'N S X=$$FMDIFF^XLFDT(NOW,DTE) I X<8 D FIL G P4

 I 'N G P4

 ; Check if same test

 S LST=$P($G(^FHPT(FHDFN,"A",ADM,"MO",N,0)),"^",2) I DTE>LST D FIL

 ;

P4 ; Check for NPO+Clr Liq > 3 days

 S A1=NOW,DTE=NOW

 F  D  Q:'A1

 .S A1=$O(^FHPT(FHDFN,"A",ADM,"AC",A1),-1) Q:'A1

 .S FHORD=$P($G(^FHPT(FHDFN,"A",ADM,"AC",A1,0)),"^",2) I 'FHORD S A1="" Q

 .S FHOR=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))

 .I $P(FHOR,"^",7)="N" S DTE=A1 Q

 .I $P(FHOR,"^",2)=CLR S DTE=A1 Q

 .S A1="" Q

 I DTE'<NOW Q

 S X=$$FMDIFF^XLFDT(NOW,DTE) Q:X<3

 S MONTX="Monitor: NPO+Clr Liq > 3 days",DTE=NOW

 S N=$O(^FHPT(FHDFN,"A",ADM,"MO","B",MONTX,""),-1) I 'N D FIL Q

 ; Check if been 3 days

 S LST=$P($G(^FHPT(FHDFN,"A",ADM,"MO",N,0)),"^",2)

 S X=$$FMDIFF^XLFDT(NOW,LST) I X>3 D FIL

 Q

P5 ;clear personalized tickler and quit

 F FHI=0:0 S FHI=$O(^FH(119,FHI)) Q:FHI'>0  F FHJ=0:0 S FHJ=$O(^FH(119,FHI,"I",FHJ)) Q:FHJ'>0  D

 .S FHJDAT=$G(^FH(119,FHI,"I",FHJ,0))

 .Q:$P(FHJDAT,U,2)'="X"

 .I $P(FHJDAT,U,1)<NOW K ^FH(119,FHI,"I",FHJ)

 Q

CLR ; Find Clear Liquid

 S CLR=$O(^FH(111,"B","CLEAR LIQUID",0)) Q:CLR

 S CLR=$O(^FH(111,"C","CLEAR LIQUID",0)) Q:CLR

 S CLR=$O(^FH(111,"C","CLR LIQ",0)) Q:CLR

 S CLR=$O(^FH(111,"C","CL",0)) Q:CLR

 Q

FIL ; File Monitor

 S FHCLIN=""

 K XQA S:FHDUZ FHCLIN=$P($G(^VA(200,FHDUZ,0)),U,1)

 D PATNAME^FHOMUTL

 I (MONTX["BMI"),($P($G(^FH(119.6,WRD,1)),"^",5)'="Y") G TFIL

 I (MONTX["Tubefeed"),($P($G(^FH(119.6,WRD,1)),"^",6)'="Y") G TFIL

 I (MONTX["Hyperals"),($P($G(^FH(119.6,WRD,1)),"^",7)'="Y") G TFIL

 I (MONTX["Albumin"),($P($G(^FH(119.6,WRD,1)),"^",8)'="Y") G TFIL

 I (MONTX["NPO+Clr"),($P($G(^FH(119.6,WRD,1)),"^",9)'="Y") G TFIL

 K XQA,XQAMSG,XQAOPT,XQAROU

 S XQAID="FH,"_$J_","_$H

 S XQAMSG=$E(FHPTNM,1,9)_" ("_$E(FHPTNM,1,1)_$P(FHSSN,"-",3)_"): "

 S XQAOPT="FHCTF2",XQAMSG=XQAMSG_"  "_MONTX_" "_$E(DTE,4,5)_"/"_$E(DTE,6,7)_"/"_$E(DTE,2,3)_"    Clinician: "_$G(FHCLIN)

 F A=0:0 S A=$O(^FH(119.6,WRD,2,A)) Q:A'>0  S TK=$P($G(^FH(119.6,WRD,2,A,0)),U,1),XQA(TK)=""

 I '$D(XQA(FHDUZ)) S XQA(FHDUZ)=""

 D SETUP^XQALERT

 ;

TFIL ;

 Q:$G(MONTX)=""

 S FHTFLG=0

 F I=0:0 S I=$O(^FH(119,FHDUZ,"I",I)) Q:I'>0  D

 .S FHTDT1=$P(I,".",1)

 .S FHTICK=^FH(119,FHDUZ,"I",I,0),FHTMO=$P(FHTICK,"^",3),FHTDFN=$P(FHTICK,"^",4)

 .I (FHTMO=MONTX),(FHTDFN=DFN),(FHTDT1=FHEDT) S FHTFLG=1

 Q:FHTFLG  ;only one monitor for the same day, same clinician and same pt.

 L +^FHPT(FHDFN,"A",ADM,"MO",0)

 I '$D(^FHPT(FHDFN,"A",ADM,"MO",0)) S ^FHPT(FHDFN,"A",ADM,"MO",0)="^115.11^^"

 L -^FHPT(FHDFN,"A",ADM,"MO",0)

 K DIC,DD,DO,DINUM S DIC="^FHPT(FHDFN,""A"",ADM,""MO"",",DIC(0)="L",DA(1)=ADM,DA(2)=FHDFN,DLAYGO=115,X=MONTX D FILE^DICN K DIC,DLAYGO

 Q:Y<1  S MONIFN=+Y

 S $P(^FHPT(FHDFN,"A",ADM,"MO",MONIFN,0),"^",2)=DTE,^FHPT(FHDFN,"A",ADM,"MO","AC",DTE,MONIFN)=""

CRT ;create tickler

 S FHTF=DTE_"^M^"_MONTX_"^"_DFN_"^"_ADM_"^"_MONIFN

 D:FHDUZ FILE^FHCTF2

 Q

FHCTF5    ; HIOFO/REL/FAI - Check Inpatients for Monitors ;08/29/06  14:43

 +1       ;;5.5;Dietetics;**4,8**;Jan 28, 2005;Build 28

 +2       ;3/14/07 - patch 8 adds the nutrition assessment alert.

 +3        DO NOW^%DTC

           SET NOW=%

           DO CLR

 +4        SET FHEDT=$PIECE(NOW,".")

 +5        FOR WRD=0:0

               SET WRD=$ORDER(^FH(119.6,WRD))

               IF WRD<1

                   QUIT 

               SET FHDUZ=$PIECE($GET(^(WRD,0)),"^",2)

               FOR FHDFN=0:0

                   SET FHDFN=$ORDER(^FHPT("AW",WRD,FHDFN))

                   IF FHDFN'>0

                       QUIT 

                   SET ADM=$GET(^FHPT("AW",WRD,FHDFN))

                   DO PAT

 +6        DO P5

 +7        KILL %,A1,A2,ADM,BMI,CLR,DA,DD,DFN,DIC,DTE,FHDUZ,FHOR,FHORD,FHTF

 +8        KILL GMRVSTR,HT,L,LST,MONIFN,MONTX,N,NOW,PX,STOP,TF,WRD,WT,X,X0,Y

 +9        KILL I,FHTMO,FHTFLG,FHEDT,FHTICK,FHTDFN,FHTDT1,FHWTDT,FHHTDT,WARD,FHGMDT

 +10       KILL A,A0,AGE,BID,DEAD,FDA,FHAGE,FHBID,FHCLIN,FHDFN,FHI,FHI115,FHJ,FHJDAT,FHDFN

 +11       KILL FHPTNM,FHPCZN,FHSEX,FHSSN,FHHDAT,FILE,HTM,IEN,IEN200,NAM,PID,SEX

 +12       QUIT 

PAT       ;; Check a patient

 +1        DO PATNAME^FHOMUTL

           IF DFN=""

               QUIT 

 +2        SET Y=^DPT(DFN,0)

           SET NAM=$PIECE(Y,"^",1)

           SET SEX=$PIECE(Y,"^",2)

           SET DOB=$PIECE(Y,"^",3)

 +3        SET AGE=""

           IF DOB'=""

               SET AGE=$EXTRACT(NOW,1,3)-$EXTRACT(DOB,1,3)-($EXTRACT(NOW,4,7)<$EXTRACT(DOB,4,7))

 +4        SET DEAD=$PIECE($GET(^DPT(DFN,.35)),"^",1)

           IF DEAD'=""

               QUIT 

 +5       ;creates alert for nutrition assessment(follow-up dt & food/drug interaction.

           DO ALRT^FHASM2A

 +6       ;

P0        ; Calculate BMI

 +1        SET GMRVSTR="WT"

           DO EN6^GMRVUTL

           SET WT=$PIECE(X,"^",8)

           SET FHWTDT=$PIECE(X,"^",1)

 +2        SET GMRVSTR="HT"

           DO EN6^GMRVUTL

           SET HT=$PIECE(X,"^",8)

           SET FHHTDT=$PIECE(X,"^",1)

 +3        SET FHGMDT=$SELECT(FHWTDT>FHHTDT:FHWTDT,FHHTDT>FHWTDT:FHHTDT,1:FHWTDT)

 +4        SET BMI=""

           IF WT

               IF HT

                   SET A2=HT*.0254

                   SET BMI=+$JUSTIFY(WT/2.2/(A2*A2),0,1)

 +5        IF $GET(BMI)=""!($GET(BMI)'<18.5)

               GOTO P1

 +6        SET MONTX="Monitor: BMI < 18.5"

           SET DTE=NOW

 +7        SET N=$ORDER(^FHPT(FHDFN,"A",ADM,"MO","B",MONTX,""),-1)

           IF 'N

               IF (FHGMDT>(FHEDT-7))

                   DO FIL

                   GOTO P1

 +8        IF 'N

               GOTO P1

 +9       ; Check if been 30 days

 +10       SET LST=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"MO",N,0)),"^",2)

 +11       SET X=$$FMDIFF^XLFDT(DTE,LST)

           IF (X>30)

               DO FIL

P1        ; Check for current Tubefeeding

 +1        SET TF=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",4)

           IF 'TF

               GOTO P2

 +2        SET MONTX="Monitor: On Tubefeeding"

           SET DTE=NOW

 +3        SET N=$ORDER(^FHPT(FHDFN,"A",ADM,"MO","B",MONTX,""),-1)

           IF 'N

               DO FIL

               GOTO P2

 +4       ; Check if been 7 days

 +5        SET LST=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"MO",N,0)),"^",2)

 +6        SET X=$$FMDIFF^XLFDT(DTE,LST)

           IF X>7

               DO FIL

P2        ; Check for Hyperals

 +1        SET MONTX=""

           SET DTE=NOW

 +2        DO PSS435^PSS55(DFN,,"FHIV")

           FOR DA=0:0

               SET DA=$ORDER(^TMP($JOB,"FHIV",DA))

               IF DA<1

                   QUIT 

               Begin DoDot:1

 +3                SET (X0,HTM)=$PIECE($GET(^TMP($JOB,"FHIV",DA,.02)),"^",2)

                   IF X0>NOW

                       QUIT 

 +4                SET MONTX="Monitor: On Hyperals"

                   DO FIL

                   QUIT 

               End DoDot:1

 +5       ;

P3        ; Check for Serum Albumin

 +1        SET MONTX=""

           SET PX=6

           DO LAB^FHASM4

           IF $DATA(^TMP($JOB,"LRTST"))

               Begin DoDot:1

 +2                FOR L=0:0

                       SET L=$ORDER(^TMP($JOB,"LRTST",L))

                       IF L<1

                           QUIT 

                       SET Y=$TRANSLATE($PIECE(^(L),"^",6)," ","")

                       IF Y'?1A.E

                           IF Y<2.8

                               SET MONTX="Monitor: Albumin < 2.8"

                               SET DTE=$PIECE(^(L),"^",7)

               End DoDot:1

 +3        IF MONTX=""

               GOTO P4

 +4        SET N=$ORDER(^FHPT(FHDFN,"A",ADM,"MO","B",MONTX,""),-1)

 +5       ;process new Albumin if old test date is within 7 days.

 +6        IF 'N

               SET X=$$FMDIFF^XLFDT(NOW,DTE)

               IF X<8

                   DO FIL

                   GOTO P4

 +7        IF 'N

               GOTO P4

 +8       ; Check if same test

 +9        SET LST=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"MO",N,0)),"^",2)

           IF DTE>LST

               DO FIL

 +10      ;

P4        ; Check for NPO+Clr Liq > 3 days

 +1        SET A1=NOW

           SET DTE=NOW

 +2        FOR 

               Begin DoDot:1

 +3                SET A1=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",A1),-1)

                   IF 'A1

                       QUIT 

 +4                SET FHORD=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"AC",A1,0)),"^",2)

                   IF 'FHORD

                       SET A1=""

                       QUIT 

 +5                SET FHOR=$GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))

 +6                IF $PIECE(FHOR,"^",7)="N"

                       SET DTE=A1

                       QUIT 

 +7                IF $PIECE(FHOR,"^",2)=CLR

                       SET DTE=A1

                       QUIT 

 +8                SET A1=""

                   QUIT 

               End DoDot:1

               IF 'A1

                   QUIT 

 +9        IF DTE'<NOW

               QUIT 

 +10       SET X=$$FMDIFF^XLFDT(NOW,DTE)

           IF X<3

               QUIT 

 +11       SET MONTX="Monitor: NPO+Clr Liq > 3 days"

           SET DTE=NOW

 +12       SET N=$ORDER(^FHPT(FHDFN,"A",ADM,"MO","B",MONTX,""),-1)

           IF 'N

               DO FIL

               QUIT 

 +13      ; Check if been 3 days

 +14       SET LST=$PIECE($GET(^FHPT(FHDFN,"A",ADM,"MO",N,0)),"^",2)

 +15       SET X=$$FMDIFF^XLFDT(NOW,LST)

           IF X>3

               DO FIL

 +16       QUIT 

P5        ;clear personalized tickler and quit

 +1        FOR FHI=0:0

               SET FHI=$ORDER(^FH(119,FHI))

               IF FHI'>0

                   QUIT 

               FOR FHJ=0:0

                   SET FHJ=$ORDER(^FH(119,FHI,"I",FHJ))

                   IF FHJ'>0

                       QUIT 

                   Begin DoDot:1

 +2                    SET FHJDAT=$GET(^FH(119,FHI,"I",FHJ,0))

 +3                    IF $PIECE(FHJDAT,U,2)'="X"

                           QUIT 

 +4                    IF $PIECE(FHJDAT,U,1)<NOW

                           KILL ^FH(119,FHI,"I",FHJ)

                   End DoDot:1

 +5        QUIT 

CLR       ; Find Clear Liquid

 +1        SET CLR=$ORDER(^FH(111,"B","CLEAR LIQUID",0))

           IF CLR

               QUIT 

 +2        SET CLR=$ORDER(^FH(111,"C","CLEAR LIQUID",0))

           IF CLR

               QUIT 

 +3        SET CLR=$ORDER(^FH(111,"C","CLR LIQ",0))

           IF CLR

               QUIT 

 +4        SET CLR=$ORDER(^FH(111,"C","CL",0))

           IF CLR

               QUIT 

 +5        QUIT 

FIL       ; File Monitor

 +1        SET FHCLIN=""

 +2        KILL XQA

           IF FHDUZ

               SET FHCLIN=$PIECE($GET(^VA(200,FHDUZ,0)),U,1)

 +3        DO PATNAME^FHOMUTL

 +4        IF (MONTX["BMI")

               IF ($PIECE($GET(^FH(119.6,WRD,1)),"^",5)'="Y")

                   GOTO TFIL

 +5        IF (MONTX["Tubefeed")

               IF ($PIECE($GET(^FH(119.6,WRD,1)),"^",6)'="Y")

                   GOTO TFIL

 +6        IF (MONTX["Hyperals")

               IF ($PIECE($GET(^FH(119.6,WRD,1)),"^",7)'="Y")

                   GOTO TFIL

 +7        IF (MONTX["Albumin")

               IF ($PIECE($GET(^FH(119.6,WRD,1)),"^",8)'="Y")

                   GOTO TFIL

 +8        IF (MONTX["NPO+Clr")

               IF ($PIECE($GET(^FH(119.6,WRD,1)),"^",9)'="Y")

                   GOTO TFIL

 +9        KILL XQA,XQAMSG,XQAOPT,XQAROU

 +10       SET XQAID="FH,"_$JOB_","_$HOROLOG

 +11       SET XQAMSG=$EXTRACT(FHPTNM,1,9)_" ("_$EXTRACT(FHPTNM,1,1)_$PIECE(FHSSN,"-",3)_"): "

 +12       SET XQAOPT="FHCTF2"

           SET XQAMSG=XQAMSG_"  "_MONTX_" "_$EXTRACT(DTE,4,5)_"/"_$EXTRACT(DTE,6,7)_"/"_$EXTRACT(DTE,2,3)_"    Clinician: "_$GET(FHCLIN)

 +13       FOR A=0:0

               SET A=$ORDER(^FH(119.6,WRD,2,A))

               IF A'>0

                   QUIT 

               SET TK=$PIECE($GET(^FH(119.6,WRD,2,A,0)),U,1)

               SET XQA(TK)=""

 +14       IF '$DATA(XQA(FHDUZ))

               SET XQA(FHDUZ)=""

 +15       DO SETUP^XQALERT

 +16      ;

TFIL      ;

 +1        IF $GET(MONTX)=""

               QUIT 

 +2        SET FHTFLG=0

 +3        FOR I=0:0

               SET I=$ORDER(^FH(119,FHDUZ,"I",I))

               IF I'>0

                   QUIT 

               Begin DoDot:1

 +4                SET FHTDT1=$PIECE(I,".",1)

 +5                SET FHTICK=^FH(119,FHDUZ,"I",I,0)

                   SET FHTMO=$PIECE(FHTICK,"^",3)

                   SET FHTDFN=$PIECE(FHTICK,"^",4)

 +6                IF (FHTMO=MONTX)

                       IF (FHTDFN=DFN)

                           IF (FHTDT1=FHEDT)

                               SET FHTFLG=1

               End DoDot:1

 +7       ;only one monitor for the same day, same clinician and same pt.

           IF FHTFLG

               QUIT 

 +8        LOCK +^FHPT(FHDFN,"A",ADM,"MO",0)

 +9        IF '$DATA(^FHPT(FHDFN,"A",ADM,"MO",0))

               SET ^FHPT(FHDFN,"A",ADM,"MO",0)="^115.11^^"

 +10       LOCK -^FHPT(FHDFN,"A",ADM,"MO",0)

 +11       KILL DIC,DD,DO,DINUM

           SET DIC="^FHPT(FHDFN,""A"",ADM,""MO"","

           SET DIC(0)="L"

           SET DA(1)=ADM

           SET DA(2)=FHDFN

           SET DLAYGO=115

           SET X=MONTX

           DO FILE^DICN

           KILL DIC,DLAYGO

 +12       IF Y<1

               QUIT 

           SET MONIFN=+Y

 +13       SET $PIECE(^FHPT(FHDFN,"A",ADM,"MO",MONIFN,0),"^",2)=DTE

           SET ^FHPT(FHDFN,"A",ADM,"MO","AC",DTE,MONIFN)=""

CRT       ;create tickler

 +1        SET FHTF=DTE_"^M^"_MONTX_"^"_DFN_"^"_ADM_"^"_MONIFN

 +2        IF FHDUZ

               DO FILE^FHCTF2

 +3        QUIT