FHWHEA ; HISC/REL - Health Summary ;7/16/96 15:47
;;5.5;DIETETICS;**1,8**;Jan 28, 2005;Build 28
;patch #8 - adding Nutrition Assessment (follow-up date and comment) in the "NA" node.
S FH9=9999999,FHS1=$S(GMTS2<1:1,1:FH9-GMTS2),FHS2=$S(GMTS1<1:FH9,1:FH9-GMTS1)
K ^UTILITY($J) S (FHN1,FHN2,FHN3,FHN4)=0
; Nutrition Status in inverse order
S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q
S FHL=0 F FHX1=GMTS1:0 S FHX1=$O(^FHPT(FHDFN,"S",FHX1)) Q:FHX1'>0!(FHX1>GMTS2) I $D(^(FHX1,0)) S FHX2=^(0) D NS S ^UTILITY($J,"NS",FHX1,0)=$P(FHX2,"^",1)_"^"_FHY,FHL=FHL+1 I GMTSNDM=FHL Q
; Dietetic Encounters
F FHX1=FHS1:0 S FHX1=$O(^FHEN("AP",DFN,FHX1)) Q:FHX1=""!(FHX1>FHS2) F FHI=0:0 S FHI=$O(^FHEN("AP",DFN,FHX1,FHI)) Q:FHI<1 D EN
F FHADM=0:0 S FHADM=$O(^FHPT(FHDFN,"A",FHADM)) Q:FHADM'>0 D CHK
;add nutrition assessment (Follow-up date & comments.
; where ^utility($j,"NA",date,1)=follow-up date
; date,2)=pt's allergy
; date,3)=1nd line comment
; date,4)=2rd line comment and so on...
F FHI=0:0 S FHI=$O(^FHPT(FHDFN,"N",FHI)) Q:FHI'>0 I $D(^(FHI,"DI")) D NAD
I GMTSNDM'>0 G KIL
I FHN1>GMTSNDM S FHL=0 F FHI=0:0 S FHI=$O(^UTILITY($J,"DI",FHI)) Q:FHI="" S FHL=FHL+1 I FHL>GMTSNDM K ^UTILITY($J,"DI",FHI)
I FHN2>GMTSNDM S FHL=0 F FHI=0:0 S FHI=$O(^UTILITY($J,"TF",FHI)) Q:FHI="" S FHL=FHL+1 I FHL>GMTSNDM K ^UTILITY($J,"TF",FHI)
I FHN3>GMTSNDM S FHL=0 F FHI=0:0 S FHI=$O(^UTILITY($J,"SF",FHI)) Q:FHI="" S FHL=FHL+1 I FHL>GMTSNDM K ^UTILITY($J,"SF",FHI)
I FHN4>GMTSNDM S FHL=0 F FHI=0:0 S FHI=$O(^UTILITY($J,"EN",FHI)) Q:FHI="" S FHL=FHL+1 I FHL>GMTSNDM K ^UTILITY($J,"EN",FHI)
G KIL
CHK ;
S FHY=$P($G(^DGPM(FHADM,0)),"^",17) S:FHY>0 FHY=$P($G(^DGPM(+FHY,0)),"^",1)
I FHY,FHY<FHS1 Q
; Diet Order in inverse order
S FHP="" F FHI=FHS1:0 S FHI=$O(^FHPT(FHDFN,"A",FHADM,"AC",FHI)) Q:FHI=""!(FHI>FHS2) I $D(^(FHI,0)) S FHX=^(0) D DI S ^UTILITY($J,"DI",(FH9-FHI),0)=FHX,FHN1=FHN1+1 S:FHP $P(^UTILITY($J,"DI",FHP,0),"^",2)=FHI S FHP=FH9-FHI
; Tubefeeding in inverse order
F FHI=0:0 S FHI=$O(^FHPT(FHDFN,"A",FHADM,"TF",FHI)) Q:FHI="" I $D(^(FHI,0)) S FHX=^(0) D TF I FHX S ^UTILITY($J,"TF",(FH9-FHX1),0)=FHX,FHN2=FHN2+1
; Supplemental feeding in inverse order
F FHI=0:0 S FHI=$O(^FHPT(FHDFN,"A",FHADM,"SF",FHI)) Q:FHI="" I $D(^(FHI,0)) S FHX=^(0) D SF I FHX S ^UTILITY($J,"SF",FH9-FHX1,0)=FHX,FHN3=FHN3+1
Q
DI ; Decode Diet Order
S FHX=^FHPT(FHDFN,"A",FHADM,"DI",$P(FHX,"^",2),0),FHX2=$G(^(1)),FHX3=""
S FHOR=$P(FHX,"^",2,6),FHLD=$P(FHX,"^",7),FHY=""
I FHLD'="" S FHDU=";"_$P(^DD(115.02,6,0),"^",3),%=$F(FHDU,";"_FHLD_":") S:%>0 FHY=$P($E(FHDU,%,999),";",1) K % G D1
S FHY="" F FHK1=1:1:5 S FHL=$P(FHOR,"^",FHK1) I FHL S:FHY'="" FHY=FHY_", " S FHY=FHY_$P($G(^FH(111,FHL,0)),"^",7)
S FHX3=$P(FHX,"^",8) S:FHX3'="" FHX3=$S(FHX3="T":"Tray",FHX3="D":"Dining Room",1:"Cafeteria")
D1 S FHX=FHI_"^"_$P(FHX,"^",10)_"^"_FHY_"^"_FHX2_"^"_FHX3 Q
SF ; Decode Supp. Fdg.
S FHX1=$P(FHX,"^",2) I FHX1<FHS1!(FHX1>FHS2) S FHX="" Q
S FHL=4 F FHK1=1:1:3 S FHN(FHK1)="" F FHK2=1:1:4 S FHX2=$P(FHX,"^",FHL+1),FHX3=$P(FHX,"^",FHL+2),FHL=FHL+2 I FHX2 S:FHN(FHK1)'="" FHN(FHK1)=FHN(FHK1)_"; " S FHN(FHK1)=FHN(FHK1)_$S(FHX3:FHX3,1:1)_" "_$P($G(^FH(118,FHX2,0)),"^",1)
I $L(FHX1_"^"_$P(FHX,"^",32)_"^"_FHN(1)_"^"_FHN(2)_"^"_FHN(3))>240 D BRK
S FHX=(FHX1\1)_"^"_$P(FHX,"^",32)_"^"_FHN(1)_"^"_FHN(2)_"^"_FHN(3)
Q
NS ; Decode Nut Status
S FHY=$P($G(^FH(115.4,+$P(FHX2,"^",2),0)),"^",2) Q
TF ; Decode Tubefeeding
S FHX1=$P(FHX,"^",1) I FHX1<FHS1!(FHX1>FHS2) S FHX="" Q
S %=$O(^FHPT(FHDFN,"A",FHADM,"TF",FHI,"P",0)) S:% %=^(%,0)
S FHX2=$P(%,"^",1),FHX3=$P(%,"^",2),FHX4=$P(%,"^",3)
I FHX4["CC" S QUAFI=$P(FHX4,"CC",1),QUASE=$P(FHX4,"CC",2),FHX4=QUAFI_"ML"_QUASE
S:FHX2 FHX2=$S($D(^FH(118.2,FHX2,0)):$P(^(0),"^",1),1:" ")
S:FHX3 FHX3=$S(FHX3=4:"Full",FHX3=1:"1/4",FHX3=2:"1/2",1:"3/4")
S FHX=FHX1_"^"_$P(FHX,"^",11)_"^"_FHX2_"^"_FHX3_"^"_FHX4_"^"_$P(FHX,"^",6)_"^"_$P(FHX,"^",7)_"^"_$P(FHX,"^",5) Q
EN ; Decode Dietetic Encounter
S FHX2=$G(^FHEN(FHI,0)),FHX3=$P(FHX2,"^",4) Q:'FHX3 S FHX3=$P($G(^FH(115.6,+FHX3,0)),"^",1)
S FHX=FHX1_"^"_FHX3_"^"_$P(FHX2,"^",11)_"^"_$P($G(^FHEN(FHI,"P",DFN,0)),"^",4)
S ^UTILITY($J,"EN",(FH9-FHX1),0)=FHX,FHN4=FHN4+1 Q
Q
;
NAD ;Nutrition Assessment.
S FHX=$G(^FHPT(FHDFN,"N",FHI,0))
S FHDI=$G(^FHPT(FHDFN,"N",FHI,"DI"))
S FHX1=$P(FHX,U,1)
S FHFUD=$P(FHDI,U,5),FHNAST=$P(FHDI,U,6)
S DTP=FHFUD D DTP^FH S FHFUD=$E(DTP,1,9)
I (FHNAST="")!(FHNAST="W") Q
I (FHX1<FHS1)!(FHX1>FHS2) Q
S FHNA=1
S ^UTILITY($J,"NA",(FH9-FHX1),FHNA)="Follow-up Date: "_FHFUD
D ALG^FHCLN
S FHNA=FHNA+1 S ^UTILITY($J,"NA",(FH9-FHX1),FHNA)="Patient's Allergy: "_ALG
I $D(^FHPT(FHDFN,"N",FHI,"X")) S FHNA=FHNA+1 S ^UTILITY($J,"NA",(FH9-FHX1),FHNA)="Comment: "
F FHI1=0:0 S FHI1=$O(^FHPT(FHDFN,"N",FHI,"X",FHI1)) Q:FHI1'>0 D
.S FHNA=FHNA+1
.S ^UTILITY($J,"NA",(FH9-FHX1),FHNA)=$G(^FHPT(FHDFN,"N",FHI,"X",FHI1,0))
Q
BRK ; Break Supplemental Feeding
S FHVAL=""
D STP(FHN(1),.FHVAL) S FHN(1)=FHVAL
D STP(FHN(2),.FHVAL) S FHN(2)=FHVAL
D STP(FHN(3),.FHVAL) S FHN(3)=FHVAL
Q
STP(FHVAL1,FHVAL2) ; Strip Excess Spaces and truncate SF from 20 to 16 char
S FHVAL2=""
F FHK2=1:1:4 S FHP1=$P(FHVAL1,";",FHK2) I FHP1'="" S:$E(FHP1,1)=" " FHP1=$E(FHP1,2,$L(FHP1)) S:FHVAL2'="" FHVAL2=FHVAL2_";" S FHVAL2=FHVAL2_$E(FHP1,1,16)
Q
KIL K %,FHADM,FHDU,FHI,FHK1,FHK2,FHL,FHLD,FHN,FHN1,FHN2,FHN3,FHN4,FHOR,FHP,FHP1,FHX,FHX1,FHX2,FHX3,FHX4,FHS1,FHS2,FH9,FHFHY,FHVAL,FHVAL1,FHVAL2
K FHI1,FHNA,FHFUD,FHNAST,FHDI,FHDFN,FHY,FHZ115,FLAG
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHWHEA 5616 printed Oct 16, 2024@17:56:08 Page 2
FHWHEA ; HISC/REL - Health Summary ;7/16/96 15:47
+1 ;;5.5;DIETETICS;**1,8**;Jan 28, 2005;Build 28
+2 ;patch #8 - adding Nutrition Assessment (follow-up date and comment) in the "NA" node.
+3 SET FH9=9999999
SET FHS1=$SELECT(GMTS2<1:1,1:FH9-GMTS2)
SET FHS2=$SELECT(GMTS1<1:FH9,1:FH9-GMTS1)
+4 KILL ^UTILITY($JOB)
SET (FHN1,FHN2,FHN3,FHN4)=0
+5 ; Nutrition Status in inverse order
+6 SET FHZ115="P"_DFN
DO CHECK^FHOMDPA
IF FHDFN=""
QUIT
+7 SET FHL=0
FOR FHX1=GMTS1:0
SET FHX1=$ORDER(^FHPT(FHDFN,"S",FHX1))
if FHX1'>0!(FHX1>GMTS2)
QUIT
IF $DATA(^(FHX1,0))
SET FHX2=^(0)
DO NS
SET ^UTILITY($JOB,"NS",FHX1,0)=$PIECE(FHX2,"^",1)_"^"_FHY
SET FHL=FHL+1
IF GMTSNDM=FHL
QUIT
+8 ; Dietetic Encounters
+9 FOR FHX1=FHS1:0
SET FHX1=$ORDER(^FHEN("AP",DFN,FHX1))
if FHX1=""!(FHX1>FHS2)
QUIT
FOR FHI=0:0
SET FHI=$ORDER(^FHEN("AP",DFN,FHX1,FHI))
if FHI<1
QUIT
DO EN
+10 FOR FHADM=0:0
SET FHADM=$ORDER(^FHPT(FHDFN,"A",FHADM))
if FHADM'>0
QUIT
DO CHK
+11 ;add nutrition assessment (Follow-up date & comments.
+12 ; where ^utility($j,"NA",date,1)=follow-up date
+13 ; date,2)=pt's allergy
+14 ; date,3)=1nd line comment
+15 ; date,4)=2rd line comment and so on...
+16 FOR FHI=0:0
SET FHI=$ORDER(^FHPT(FHDFN,"N",FHI))
if FHI'>0
QUIT
IF $DATA(^(FHI,"DI"))
DO NAD
+17 IF GMTSNDM'>0
GOTO KIL
+18 IF FHN1>GMTSNDM
SET FHL=0
FOR FHI=0:0
SET FHI=$ORDER(^UTILITY($JOB,"DI",FHI))
if FHI=""
QUIT
SET FHL=FHL+1
IF FHL>GMTSNDM
KILL ^UTILITY($JOB,"DI",FHI)
+19 IF FHN2>GMTSNDM
SET FHL=0
FOR FHI=0:0
SET FHI=$ORDER(^UTILITY($JOB,"TF",FHI))
if FHI=""
QUIT
SET FHL=FHL+1
IF FHL>GMTSNDM
KILL ^UTILITY($JOB,"TF",FHI)
+20 IF FHN3>GMTSNDM
SET FHL=0
FOR FHI=0:0
SET FHI=$ORDER(^UTILITY($JOB,"SF",FHI))
if FHI=""
QUIT
SET FHL=FHL+1
IF FHL>GMTSNDM
KILL ^UTILITY($JOB,"SF",FHI)
+21 IF FHN4>GMTSNDM
SET FHL=0
FOR FHI=0:0
SET FHI=$ORDER(^UTILITY($JOB,"EN",FHI))
if FHI=""
QUIT
SET FHL=FHL+1
IF FHL>GMTSNDM
KILL ^UTILITY($JOB,"EN",FHI)
+22 GOTO KIL
CHK ;
+1 SET FHY=$PIECE($GET(^DGPM(FHADM,0)),"^",17)
if FHY>0
SET FHY=$PIECE($GET(^DGPM(+FHY,0)),"^",1)
+2 IF FHY
IF FHY<FHS1
QUIT
+3 ; Diet Order in inverse order
+4 SET FHP=""
FOR FHI=FHS1:0
SET FHI=$ORDER(^FHPT(FHDFN,"A",FHADM,"AC",FHI))
if FHI=""!(FHI>FHS2)
QUIT
IF $DATA(^(FHI,0))
SET FHX=^(0)
DO DI
SET ^UTILITY($JOB,"DI",(FH9-FHI),0)=FHX
SET FHN1=FHN1+1
if FHP
SET $PIECE(^UTILITY($JOB,"DI",FHP,0),"^",2)=FHI
SET FHP=FH9-FHI
+5 ; Tubefeeding in inverse order
+6 FOR FHI=0:0
SET FHI=$ORDER(^FHPT(FHDFN,"A",FHADM,"TF",FHI))
if FHI=""
QUIT
IF $DATA(^(FHI,0))
SET FHX=^(0)
DO TF
IF FHX
SET ^UTILITY($JOB,"TF",(FH9-FHX1),0)=FHX
SET FHN2=FHN2+1
+7 ; Supplemental feeding in inverse order
+8 FOR FHI=0:0
SET FHI=$ORDER(^FHPT(FHDFN,"A",FHADM,"SF",FHI))
if FHI=""
QUIT
IF $DATA(^(FHI,0))
SET FHX=^(0)
DO SF
IF FHX
SET ^UTILITY($JOB,"SF",FH9-FHX1,0)=FHX
SET FHN3=FHN3+1
+9 QUIT
DI ; Decode Diet Order
+1 SET FHX=^FHPT(FHDFN,"A",FHADM,"DI",$PIECE(FHX,"^",2),0)
SET FHX2=$GET(^(1))
SET FHX3=""
+2 SET FHOR=$PIECE(FHX,"^",2,6)
SET FHLD=$PIECE(FHX,"^",7)
SET FHY=""
+3 IF FHLD'=""
SET FHDU=";"_$PIECE(^DD(115.02,6,0),"^",3)
SET %=$FIND(FHDU,";"_FHLD_":")
if %>0
SET FHY=$PIECE($EXTRACT(FHDU,%,999),";",1)
KILL %
GOTO D1
+4 SET FHY=""
FOR FHK1=1:1:5
SET FHL=$PIECE(FHOR,"^",FHK1)
IF FHL
if FHY'=""
SET FHY=FHY_", "
SET FHY=FHY_$PIECE($GET(^FH(111,FHL,0)),"^",7)
+5 SET FHX3=$PIECE(FHX,"^",8)
if FHX3'=""
SET FHX3=$SELECT(FHX3="T":"Tray",FHX3="D":"Dining Room",1:"Cafeteria")
D1 SET FHX=FHI_"^"_$PIECE(FHX,"^",10)_"^"_FHY_"^"_FHX2_"^"_FHX3
QUIT
SF ; Decode Supp. Fdg.
+1 SET FHX1=$PIECE(FHX,"^",2)
IF FHX1<FHS1!(FHX1>FHS2)
SET FHX=""
QUIT
+2 SET FHL=4
FOR FHK1=1:1:3
SET FHN(FHK1)=""
FOR FHK2=1:1:4
SET FHX2=$PIECE(FHX,"^",FHL+1)
SET FHX3=$PIECE(FHX,"^",FHL+2)
SET FHL=FHL+2
IF FHX2
if FHN(FHK1)'=""
SET FHN(FHK1)=FHN(FHK1)_"; "
SET FHN(FHK1)=FHN(FHK1)_$SELECT(FHX3:FHX3,1:1)_" "_$PIECE($GET(^FH(118,FHX2,0)),"^",1)
+3 IF $LENGTH(FHX1_"^"_$PIECE(FHX,"^",32)_"^"_FHN(1)_"^"_FHN(2)_"^"_FHN(3))>240
DO BRK
+4 SET FHX=(FHX1\1)_"^"_$PIECE(FHX,"^",32)_"^"_FHN(1)_"^"_FHN(2)_"^"_FHN(3)
+5 QUIT
NS ; Decode Nut Status
+1 SET FHY=$PIECE($GET(^FH(115.4,+$PIECE(FHX2,"^",2),0)),"^",2)
QUIT
TF ; Decode Tubefeeding
+1 SET FHX1=$PIECE(FHX,"^",1)
IF FHX1<FHS1!(FHX1>FHS2)
SET FHX=""
QUIT
+2 SET %=$ORDER(^FHPT(FHDFN,"A",FHADM,"TF",FHI,"P",0))
if %
SET %=^(%,0)
+3 SET FHX2=$PIECE(%,"^",1)
SET FHX3=$PIECE(%,"^",2)
SET FHX4=$PIECE(%,"^",3)
+4 IF FHX4["CC"
SET QUAFI=$PIECE(FHX4,"CC",1)
SET QUASE=$PIECE(FHX4,"CC",2)
SET FHX4=QUAFI_"ML"_QUASE
+5 if FHX2
SET FHX2=$SELECT($DATA(^FH(118.2,FHX2,0)):$PIECE(^(0),"^",1),1:" ")
+6 if FHX3
SET FHX3=$SELECT(FHX3=4:"Full",FHX3=1:"1/4",FHX3=2:"1/2",1:"3/4")
+7 SET FHX=FHX1_"^"_$PIECE(FHX,"^",11)_"^"_FHX2_"^"_FHX3_"^"_FHX4_"^"_$PIECE(FHX,"^",6)_"^"_$PIECE(FHX,"^",7)_"^"_$PIECE(FHX,"^",5)
QUIT
EN ; Decode Dietetic Encounter
+1 SET FHX2=$GET(^FHEN(FHI,0))
SET FHX3=$PIECE(FHX2,"^",4)
if 'FHX3
QUIT
SET FHX3=$PIECE($GET(^FH(115.6,+FHX3,0)),"^",1)
+2 SET FHX=FHX1_"^"_FHX3_"^"_$PIECE(FHX2,"^",11)_"^"_$PIECE($GET(^FHEN(FHI,"P",DFN,0)),"^",4)
+3 SET ^UTILITY($JOB,"EN",(FH9-FHX1),0)=FHX
SET FHN4=FHN4+1
QUIT
+4 QUIT
+5 ;
NAD ;Nutrition Assessment.
+1 SET FHX=$GET(^FHPT(FHDFN,"N",FHI,0))
+2 SET FHDI=$GET(^FHPT(FHDFN,"N",FHI,"DI"))
+3 SET FHX1=$PIECE(FHX,U,1)
+4 SET FHFUD=$PIECE(FHDI,U,5)
SET FHNAST=$PIECE(FHDI,U,6)
+5 SET DTP=FHFUD
DO DTP^FH
SET FHFUD=$EXTRACT(DTP,1,9)
+6 IF (FHNAST="")!(FHNAST="W")
QUIT
+7 IF (FHX1<FHS1)!(FHX1>FHS2)
QUIT
+8 SET FHNA=1
+9 SET ^UTILITY($JOB,"NA",(FH9-FHX1),FHNA)="Follow-up Date: "_FHFUD
+10 DO ALG^FHCLN
+11 SET FHNA=FHNA+1
SET ^UTILITY($JOB,"NA",(FH9-FHX1),FHNA)="Patient's Allergy: "_ALG
+12 IF $DATA(^FHPT(FHDFN,"N",FHI,"X"))
SET FHNA=FHNA+1
SET ^UTILITY($JOB,"NA",(FH9-FHX1),FHNA)="Comment: "
+13 FOR FHI1=0:0
SET FHI1=$ORDER(^FHPT(FHDFN,"N",FHI,"X",FHI1))
if FHI1'>0
QUIT
Begin DoDot:1
+14 SET FHNA=FHNA+1
+15 SET ^UTILITY($JOB,"NA",(FH9-FHX1),FHNA)=$GET(^FHPT(FHDFN,"N",FHI,"X",FHI1,0))
End DoDot:1
+16 QUIT
BRK ; Break Supplemental Feeding
+1 SET FHVAL=""
+2 DO STP(FHN(1),.FHVAL)
SET FHN(1)=FHVAL
+3 DO STP(FHN(2),.FHVAL)
SET FHN(2)=FHVAL
+4 DO STP(FHN(3),.FHVAL)
SET FHN(3)=FHVAL
+5 QUIT
STP(FHVAL1,FHVAL2) ; Strip Excess Spaces and truncate SF from 20 to 16 char
+1 SET FHVAL2=""
+2 FOR FHK2=1:1:4
SET FHP1=$PIECE(FHVAL1,";",FHK2)
IF FHP1'=""
if $EXTRACT(FHP1,1)=" "
SET FHP1=$EXTRACT(FHP1,2,$LENGTH(FHP1))
if FHVAL2'=""
SET FHVAL2=FHVAL2_";"
SET FHVAL2=FHVAL2_$EXTRACT(FHP1,1,16)
+3 QUIT
KIL KILL %,FHADM,FHDU,FHI,FHK1,FHK2,FHL,FHLD,FHN,FHN1,FHN2,FHN3,FHN4,FHOR,FHP,FHP1,FHX,FHX1,FHX2,FHX3,FHX4,FHS1,FHS2,FH9,FHFHY,FHVAL,FHVAL1,FHVAL2
+1 KILL FHI1,FHNA,FHFUD,FHNAST,FHDI,FHDFN,FHY,FHZ115,FLAG
+2 QUIT
