GMTSFHWZ ; SLC/JER - Dietetics extract for export ;12/16/92 09:38
;;2.5;Health Summary;;Dec 16, 1992
FHWHEA ;; GLRISC/REL - Health Summary ;1/11/91 09:11
;;4.6;;
S FH9=9999999,FHS1=$S(GMTS2<1:1,1:FH9-GMTS2),FHS2=$S(GMTS1<1:FHP,1:FH9-GMTS1)
K ^UTILITY($J) S (FHN1,FHN2,FHN3)=0
; Nutrition Status in inverse order
S FHL=0 F FHX1=GMTS1:0 S FHX1=$O(^FHPT(DFN,"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
S FHNOD="A" I ^DG(43,1,"VERSION")'>4.8 S FHNOD="DA"
F FHADM=0:0 S FHADM=$O(^FHPT(DFN,FHNOD,FHADM)) Q:FHADM'>0 D CHK
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)
G KIL
CHK ;
I FHNOD="A" S FHY=$S($D(^DGPM(FHADM,0)):$P(^(0),"^",17),1:"") S:FHY>0 FHY=$S($D(^DGPM(+FHY,0)):$P(^(0),"^",1),1:"")
I FHNOD="DA" S FHY=$S($D(^DPT(DFN,FHNOD,FHADM,1)):$P(^(1),"^",1),1:"")
I FHY,FHY<FHS1 Q
; Diet Order in inverse order
S FHP="" F FHI=FHS1:0 S FHI=$O(^FHPT(DFN,FHNOD,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(DFN,FHNOD,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(DFN,FHNOD,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(DFN,FHNOD,FHADM,"DI",$P(FHX,"^",2),0),FHX2=$S($D(^(1)):^(1),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_$S($D(^FH(111,FHL,0)):$P(^(0),"^",7),1:"")
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)_" "_$S($D(^FH(118,FHX2,0)):$P(^(0),"^",1),1:"")
S FHX=FHX1_"^"_$P(FHX,"^",32)_"^"_FHN(1)_"^"_FHN(2)_"^"_FHN(3) Q
NS ; Decode Nut Status
S FHY=$S($D(^FH(115.4,+$P(FHX2,"^",2),0)):$P(^(0),"^",2),1:"") Q
TF ; Decode Tubefeeding
S FHX1=$P(FHX,"^",1) I FHX1<FHS1!(FHX1>FHS2) S FHX="" Q
S FHX2=$P(FHX,"^",2),FHX3=$P(FHX,"^",3)
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_"^"_$P(FHX,"^",4)_"^"_$P(FHX,"^",6)_"^"_$P(FHX,"^",7)_"^"_$P(FHX,"^",5) Q
KIL K %,FHADM,FHDU,FHI,FHK1,FHK2,FHL,FHLD,FHN,FHN1,FHN2,FHN3,FHNOD,FHOR,FHP,FHX,FHX1,FHX2,FHX3,FHS1,FHS2,FH9,FHFHY Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSFHWZ 3443 printed Sep 23, 2025@19:33:37 Page 2
GMTSFHWZ ; SLC/JER - Dietetics extract for export ;12/16/92 09:38
+1 ;;2.5;Health Summary;;Dec 16, 1992
FHWHEA ;; GLRISC/REL - Health Summary ;1/11/91 09:11
+1 ;;4.6;;
+2 SET FH9=9999999
SET FHS1=$SELECT(GMTS2<1:1,1:FH9-GMTS2)
SET FHS2=$SELECT(GMTS1<1:FHP,1:FH9-GMTS1)
+3 KILL ^UTILITY($JOB)
SET (FHN1,FHN2,FHN3)=0
+4 ; Nutrition Status in inverse order
+5 SET FHL=0
FOR FHX1=GMTS1:0
SET FHX1=$ORDER(^FHPT(DFN,"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
+6 SET FHNOD="A"
IF ^DG(43,1,"VERSION")'>4.8
SET FHNOD="DA"
+7 FOR FHADM=0:0
SET FHADM=$ORDER(^FHPT(DFN,FHNOD,FHADM))
if FHADM'>0
QUIT
DO CHK
+8 IF GMTSNDM'>0
GOTO KIL
+9 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)
+10 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)
+11 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)
+12 GOTO KIL
CHK ;
+1 IF FHNOD="A"
SET FHY=$SELECT($DATA(^DGPM(FHADM,0)):$PIECE(^(0),"^",17),1:"")
if FHY>0
SET FHY=$SELECT($DATA(^DGPM(+FHY,0)):$PIECE(^(0),"^",1),1:"")
+2 IF FHNOD="DA"
SET FHY=$SELECT($DATA(^DPT(DFN,FHNOD,FHADM,1)):$PIECE(^(1),"^",1),1:"")
+3 IF FHY
IF FHY<FHS1
QUIT
+4 ; Diet Order in inverse order
+5 SET FHP=""
FOR FHI=FHS1:0
SET FHI=$ORDER(^FHPT(DFN,FHNOD,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
+6 ; Tubefeeding in inverse order
+7 FOR FHI=0:0
SET FHI=$ORDER(^FHPT(DFN,FHNOD,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
+8 ; Supplemental feeding in inverse order
+9 FOR FHI=0:0
SET FHI=$ORDER(^FHPT(DFN,FHNOD,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
+10 QUIT
DI ; Decode Diet Order
+1 SET FHX=^FHPT(DFN,FHNOD,FHADM,"DI",$PIECE(FHX,"^",2),0)
SET FHX2=$SELECT($DATA(^(1)):^(1),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_$SELECT($DATA(^FH(111,FHL,0)):$PIECE(^(0),"^",7),1:"")
+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)_" "_$SELECT($DATA(^FH(118,FHX2,0)):$PIECE(^(0),"^",1),1:"")
+3 SET FHX=FHX1_"^"_$PIECE(FHX,"^",32)_"^"_FHN(1)_"^"_FHN(2)_"^"_FHN(3)
QUIT
NS ; Decode Nut Status
+1 SET FHY=$SELECT($DATA(^FH(115.4,+$PIECE(FHX2,"^",2),0)):$PIECE(^(0),"^",2),1:"")
QUIT
TF ; Decode Tubefeeding
+1 SET FHX1=$PIECE(FHX,"^",1)
IF FHX1<FHS1!(FHX1>FHS2)
SET FHX=""
QUIT
+2 SET FHX2=$PIECE(FHX,"^",2)
SET FHX3=$PIECE(FHX,"^",3)
+3 if FHX2
SET FHX2=$SELECT($DATA(^FH(118.2,FHX2,0)):$PIECE(^(0),"^",1),1:" ")
+4 if FHX3
SET FHX3=$SELECT(FHX3=4:"Full",FHX3=1:"1/4",FHX3=2:"1/2",1:"3/4")
+5 SET FHX=FHX1_"^"_$PIECE(FHX,"^",11)_"^"_FHX2_"^"_FHX3_"^"_$PIECE(FHX,"^",4)_"^"_$PIECE(FHX,"^",6)_"^"_$PIECE(FHX,"^",7)_"^"_$PIECE(FHX,"^",5)
QUIT
KIL KILL %,FHADM,FHDU,FHI,FHK1,FHK2,FHL,FHLD,FHN,FHN1,FHN2,FHN3,FHNOD,FHOR,FHP,FHX,FHX1,FHX2,FHX3,FHS1,FHS2,FH9,FHFHY
QUIT
