- GMTSFH ; SLC/JER,MKB,KER - Dietetics Component ; 02/27/2002
- ;;2.7;Health Summary;**25,28,49,83**;Oct 20, 1995;Build 1
- ;
- ; External References
- ; DBIA 1407 ^FHWHEA
- ;
- MAIN ; Controls branching and execution
- N GMI,MAX S MAX=$S(+($G(GMTSNDM))>0:+($G(GMTSNDM)),1:99999)
- D ^FHWHEA Q:'$D(^UTILITY($J)) F GMI="DI","NS","SF","TF","EN" D @GMI
- K ^UTILITY($J),STR,COL,TX,STRT,STP,CNTR
- Q
- DI ; Diet Orders
- S CNTR=$S(+($G(GMTSNDM))>0:+($G(GMTSNDM)),1:99999)
- D CKP^GMTSUP Q:$D(GMTSQIT) W "DIETS:",!
- I '$D(^UTILITY($J,"DI")) D CKP^GMTSUP Q:$D(GMTSQIT) W "No diet orders available.",! Q
- N GMW,GMIDT S GMIDT=GMTS1 F S GMIDT=$O(^UTILITY($J,"DI",GMIDT)) Q:(GMIDT'>0)!(GMIDT>GMTS2) D DIWRT
- Q
- DIWRT ; Writes Diet Orders
- S CNTR=CNTR-1 I CNTR<0 Q
- N GMZ S GMZ=^UTILITY($J,"DI",GMIDT,0)
- S X=+$P(GMZ,U) D REGDT4^GMTSU S STRT=X
- I $P(GMZ,U,2)="" S STP="Present"
- E S X=+$P(GMZ,U,2) D REGDT4^GMTSU S STP=X
- D CKP^GMTSUP Q:$D(GMTSQIT) W STRT_" - "_STP,?25
- S STR=$S($P(GMZ,U,3)'="":$P(GMZ,U,3),1:"No diet orders on file.")
- I $L(STR)<40 W STR
- E S COL=27 D WRAP
- W:$P(GMZ,U,5)'="" ?61,"("_$P(GMZ,U,5)_")" W !
- I $P(GMZ,U,4)'="" D DICOM
- Q
- DICOM ; Writes comments for DI
- D CKP^GMTSUP Q:$D(GMTSQIT) W " Comments: "
- I $L($P(GMZ,U,4))<55 W $P(GMZ,U,4),!
- E S STR=$P(GMZ,U,4),COL=45 D WRAP W !
- Q
- NS ; Nutritional status
- I '$D(^UTILITY($J,"NS")) Q
- S CNTR=$S(+($G(GMTSNDM))>0:+($G(GMTSNDM)),1:99999)
- D CKP^GMTSUP Q:$D(GMTSQIT) W !,"NUTRITIONAL STATUS:",!
- N GMW,GMIDT
- S GMIDT=GMTS1 F S GMIDT=$O(^UTILITY($J,"NS",GMIDT)) Q:(GMIDT'>0)!(GMIDT>GMTS2) D NSWRT
- Q
- NSWRT ; Writes Nutritional Status
- S CNTR=CNTR-1 I CNTR<0 Q
- N GMZ S GMZ=^UTILITY($J,"NS",GMIDT,0)
- S X=+$P(GMZ,U) D REGDTM4^GMTSU S STRT=X
- D CKP^GMTSUP Q:$D(GMTSQIT)
- W STRT,?21,$S($P(GMZ,U,2)'="":$P(GMZ,U,2),1:"No status on file."),!
- Q
- SF ; Supplemental feeding
- I '$D(^UTILITY($J,"SF")) Q
- S CNTR=$S(+($G(GMTSNDM))>0:+($G(GMTSNDM)),1:99999)
- D CKP^GMTSUP Q:$D(GMTSQIT) W !,"SUPPLEMENTAL FEEDINGS:",!
- N GMW,GMIDT
- S GMIDT=GMTS1 F S GMIDT=$O(^UTILITY($J,"SF",GMIDT)) Q:(GMIDT'>0)!(GMIDT>GMTS2) D SFWRT
- Q
- SFWRT ; Writes Supplemental Feedings
- S CNTR=CNTR-1 I CNTR<0 Q
- N GMZ S GMZ=^UTILITY($J,"SF",GMIDT,0)
- S X=+$P(GMZ,U) D REGDT4^GMTSU S STRT=X
- I $P(GMZ,U,2)="" S STP="Present"
- E S X=+$P(GMZ,U,2) D REGDT4^GMTSU S STP=X
- D CKP^GMTSUP Q:$D(GMTSQIT) W STRT_" - "_STP,!
- D CKP^GMTSUP Q:$D(GMTSQIT) W ?14,"10 Am " S STR=$S($P(GMZ,U,3)'="":$P(GMZ,U,3),1:"No order")
- I $L(STR)<55 W STR,!
- E S COL=45 D WRAP W !
- D CKP^GMTSUP Q:$D(GMTSQIT) W ?14," 2 Pm " S STR=$S($P(GMZ,U,4)'="":$P(GMZ,U,4),1:"No order")
- I $L(STR)<55 W STR,!
- E S COL=45 D WRAP W !
- D CKP^GMTSUP Q:$D(GMTSQIT) W ?14," 8 Pm " S STR=$S($P(GMZ,U,5)'="":$P(GMZ,U,5),1:"No order")
- I $L(STR)<55 W STR,!
- E S COL=45 D WRAP W !
- Q
- TF ; Tubefeeding
- I '$D(^UTILITY($J,"TF")) Q
- S CNTR=$S(+($G(GMTSNDM))>0:+($G(GMTSNDM)),1:99999)
- D CKP^GMTSUP Q:$D(GMTSQIT) W !,"TUBE FEEDINGS:",!
- N GMW,GMIDT
- S GMIDT=GMTS1 F S GMIDT=$O(^UTILITY($J,"TF",GMIDT)) Q:(GMIDT'>0)!(GMIDT>GMTS2) D TFWRT
- Q
- TFWRT ; Writes tubefeeding
- S CNTR=CNTR-1 I CNTR<0 Q
- N GMZ S GMZ=^UTILITY($J,"TF",GMIDT,0)
- S X=+$P(GMZ,U) D REGDT4^GMTSU S STRT=X
- I $P(GMZ,U,2)="" S STP="Present"
- E S X=+$P(GMZ,U,2) D REGDT4^GMTSU S STP=X
- D CKP^GMTSUP Q:$D(GMTSQIT) W STRT_" - "_STP,!
- D CKP^GMTSUP Q:$D(GMTSQIT) W ?12,"Product: ",$P(GMZ,U,3),!
- D CKP^GMTSUP Q:$D(GMTSQIT) W ?11,"Strength: ",$P(GMZ,U,4),?51,"Quantity: ",$P(GMZ,U,5),!
- D CKP^GMTSUP Q:$D(GMTSQIT) W ?9,"Daily CC's: ",$P(GMZ,U,6),?47,"Daily KCal's: ",$P(GMZ,U,7),!
- I $P(GMZ,U,8)'="" D TFCOM
- Q
- TFCOM ; Writes comments for TF
- D CKP^GMTSUP Q:$D(GMTSQIT) W ?11,"Comments: "
- I $L($P(GMZ,U,8))<55 W $P(GMZ,U,8),!
- E S STR=$P(GMZ,U,8),COL=45 D WRAP W !
- Q
- WRAP ; Controls wrap-around feature for comments, etc.
- S TX=$F(STR," ",COL) W $E(STR,1,TX-1),!
- D CKP^GMTSUP Q:$D(GMTSQIT) W ?21,$E(STR,TX,$L(STR))
- Q
- EN ; Dietetic Encounters
- S CNTR=$S(+($G(GMTSNDM))>0:+($G(GMTSNDM)),1:99999) Q:'$D(^UTILITY($J,"EN"))
- D CKP^GMTSUP Q:$D(GMTSQIT) W !,"DIETETIC ENCOUNTERS:",! N GMW,GMIDT S GMIDT=GMTS1
- F S GMIDT=$O(^UTILITY($J,"EN",GMIDT)) Q:(GMIDT'>0)!(GMIDT>GMTS2) D
- . S CNTR=CNTR-1 I CNTR<0 Q
- . N GMZ S GMZ=^UTILITY($J,"EN",GMIDT,0)
- . S X=+$P(GMZ,U) D REGDT4^GMTSU S STRT=X
- . D CKP^GMTSUP Q:$D(GMTSQIT) W STRT,?12,$P(GMZ,U,2),!
- . I $P(GMZ,U,3)]"" D CKP^GMTSUP Q:$D(GMTSQIT) W ?6,$P(GMZ,U,3),!
- . I $P(GMZ,U,4)]"" D CKP^GMTSUP Q:$D(GMTSQIT) W ?6,$P(GMZ,U,4),!
- . I $D(^UTILITY($J,"NA",GMIDT)) D
- . . ;I $G(^UTILITY($J,"NA",GMIDT,1)) D CKP^GMTSUP Q:$D(GMTSQIT) W ?6,$G(^UTILITY($J,"NA",GMIDT,1)),!
- . . ;I $G(^UTILITY($J,"NA",GMIDT,3)) D CKP^GMTSUP Q:$D(GMTSQIT) W ?6,"Comments:",!
- . . N I S I=0 F S I=$O(^UTILITY($J,"NA",GMIDT,I)) Q:'I D CKP^GMTSUP Q:$D(GMTSQIT) W ?6,$G(^UTILITY($J,"NA",GMIDT,I)),!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSFH 4945 printed Jan 18, 2025@02:58:44 Page 2
- GMTSFH ; SLC/JER,MKB,KER - Dietetics Component ; 02/27/2002
- +1 ;;2.7;Health Summary;**25,28,49,83**;Oct 20, 1995;Build 1
- +2 ;
- +3 ; External References
- +4 ; DBIA 1407 ^FHWHEA
- +5 ;
- MAIN ; Controls branching and execution
- +1 NEW GMI,MAX
- SET MAX=$SELECT(+($GET(GMTSNDM))>0:+($GET(GMTSNDM)),1:99999)
- +2 DO ^FHWHEA
- if '$DATA(^UTILITY($JOB))
- QUIT
- FOR GMI="DI","NS","SF","TF","EN"
- DO @GMI
- +3 KILL ^UTILITY($JOB),STR,COL,TX,STRT,STP,CNTR
- +4 QUIT
- DI ; Diet Orders
- +1 SET CNTR=$SELECT(+($GET(GMTSNDM))>0:+($GET(GMTSNDM)),1:99999)
- +2 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE "DIETS:",!
- +3 IF '$DATA(^UTILITY($JOB,"DI"))
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE "No diet orders available.",!
- QUIT
- +4 NEW GMW,GMIDT
- SET GMIDT=GMTS1
- FOR
- SET GMIDT=$ORDER(^UTILITY($JOB,"DI",GMIDT))
- if (GMIDT'>0)!(GMIDT>GMTS2)
- QUIT
- DO DIWRT
- +5 QUIT
- DIWRT ; Writes Diet Orders
- +1 SET CNTR=CNTR-1
- IF CNTR<0
- QUIT
- +2 NEW GMZ
- SET GMZ=^UTILITY($JOB,"DI",GMIDT,0)
- +3 SET X=+$PIECE(GMZ,U)
- DO REGDT4^GMTSU
- SET STRT=X
- +4 IF $PIECE(GMZ,U,2)=""
- SET STP="Present"
- +5 IF '$TEST
- SET X=+$PIECE(GMZ,U,2)
- DO REGDT4^GMTSU
- SET STP=X
- +6 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE STRT_" - "_STP,?25
- +7 SET STR=$SELECT($PIECE(GMZ,U,3)'="":$PIECE(GMZ,U,3),1:"No diet orders on file.")
- +8 IF $LENGTH(STR)<40
- WRITE STR
- +9 IF '$TEST
- SET COL=27
- DO WRAP
- +10 if $PIECE(GMZ,U,5)'=""
- WRITE ?61,"("_$PIECE(GMZ,U,5)_")"
- WRITE !
- +11 IF $PIECE(GMZ,U,4)'=""
- DO DICOM
- +12 QUIT
- DICOM ; Writes comments for DI
- +1 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE " Comments: "
- +2 IF $LENGTH($PIECE(GMZ,U,4))<55
- WRITE $PIECE(GMZ,U,4),!
- +3 IF '$TEST
- SET STR=$PIECE(GMZ,U,4)
- SET COL=45
- DO WRAP
- WRITE !
- +4 QUIT
- NS ; Nutritional status
- +1 IF '$DATA(^UTILITY($JOB,"NS"))
- QUIT
- +2 SET CNTR=$SELECT(+($GET(GMTSNDM))>0:+($GET(GMTSNDM)),1:99999)
- +3 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE !,"NUTRITIONAL STATUS:",!
- +4 NEW GMW,GMIDT
- +5 SET GMIDT=GMTS1
- FOR
- SET GMIDT=$ORDER(^UTILITY($JOB,"NS",GMIDT))
- if (GMIDT'>0)!(GMIDT>GMTS2)
- QUIT
- DO NSWRT
- +6 QUIT
- NSWRT ; Writes Nutritional Status
- +1 SET CNTR=CNTR-1
- IF CNTR<0
- QUIT
- +2 NEW GMZ
- SET GMZ=^UTILITY($JOB,"NS",GMIDT,0)
- +3 SET X=+$PIECE(GMZ,U)
- DO REGDTM4^GMTSU
- SET STRT=X
- +4 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- +5 WRITE STRT,?21,$SELECT($PIECE(GMZ,U,2)'="":$PIECE(GMZ,U,2),1:"No status on file."),!
- +6 QUIT
- SF ; Supplemental feeding
- +1 IF '$DATA(^UTILITY($JOB,"SF"))
- QUIT
- +2 SET CNTR=$SELECT(+($GET(GMTSNDM))>0:+($GET(GMTSNDM)),1:99999)
- +3 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE !,"SUPPLEMENTAL FEEDINGS:",!
- +4 NEW GMW,GMIDT
- +5 SET GMIDT=GMTS1
- FOR
- SET GMIDT=$ORDER(^UTILITY($JOB,"SF",GMIDT))
- if (GMIDT'>0)!(GMIDT>GMTS2)
- QUIT
- DO SFWRT
- +6 QUIT
- SFWRT ; Writes Supplemental Feedings
- +1 SET CNTR=CNTR-1
- IF CNTR<0
- QUIT
- +2 NEW GMZ
- SET GMZ=^UTILITY($JOB,"SF",GMIDT,0)
- +3 SET X=+$PIECE(GMZ,U)
- DO REGDT4^GMTSU
- SET STRT=X
- +4 IF $PIECE(GMZ,U,2)=""
- SET STP="Present"
- +5 IF '$TEST
- SET X=+$PIECE(GMZ,U,2)
- DO REGDT4^GMTSU
- SET STP=X
- +6 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE STRT_" - "_STP,!
- +7 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE ?14,"10 Am "
- SET STR=$SELECT($PIECE(GMZ,U,3)'="":$PIECE(GMZ,U,3),1:"No order")
- +8 IF $LENGTH(STR)<55
- WRITE STR,!
- +9 IF '$TEST
- SET COL=45
- DO WRAP
- WRITE !
- +10 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE ?14," 2 Pm "
- SET STR=$SELECT($PIECE(GMZ,U,4)'="":$PIECE(GMZ,U,4),1:"No order")
- +11 IF $LENGTH(STR)<55
- WRITE STR,!
- +12 IF '$TEST
- SET COL=45
- DO WRAP
- WRITE !
- +13 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE ?14," 8 Pm "
- SET STR=$SELECT($PIECE(GMZ,U,5)'="":$PIECE(GMZ,U,5),1:"No order")
- +14 IF $LENGTH(STR)<55
- WRITE STR,!
- +15 IF '$TEST
- SET COL=45
- DO WRAP
- WRITE !
- +16 QUIT
- TF ; Tubefeeding
- +1 IF '$DATA(^UTILITY($JOB,"TF"))
- QUIT
- +2 SET CNTR=$SELECT(+($GET(GMTSNDM))>0:+($GET(GMTSNDM)),1:99999)
- +3 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE !,"TUBE FEEDINGS:",!
- +4 NEW GMW,GMIDT
- +5 SET GMIDT=GMTS1
- FOR
- SET GMIDT=$ORDER(^UTILITY($JOB,"TF",GMIDT))
- if (GMIDT'>0)!(GMIDT>GMTS2)
- QUIT
- DO TFWRT
- +6 QUIT
- TFWRT ; Writes tubefeeding
- +1 SET CNTR=CNTR-1
- IF CNTR<0
- QUIT
- +2 NEW GMZ
- SET GMZ=^UTILITY($JOB,"TF",GMIDT,0)
- +3 SET X=+$PIECE(GMZ,U)
- DO REGDT4^GMTSU
- SET STRT=X
- +4 IF $PIECE(GMZ,U,2)=""
- SET STP="Present"
- +5 IF '$TEST
- SET X=+$PIECE(GMZ,U,2)
- DO REGDT4^GMTSU
- SET STP=X
- +6 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE STRT_" - "_STP,!
- +7 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE ?12,"Product: ",$PIECE(GMZ,U,3),!
- +8 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE ?11,"Strength: ",$PIECE(GMZ,U,4),?51,"Quantity: ",$PIECE(GMZ,U,5),!
- +9 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE ?9,"Daily CC's: ",$PIECE(GMZ,U,6),?47,"Daily KCal's: ",$PIECE(GMZ,U,7),!
- +10 IF $PIECE(GMZ,U,8)'=""
- DO TFCOM
- +11 QUIT
- TFCOM ; Writes comments for TF
- +1 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE ?11,"Comments: "
- +2 IF $LENGTH($PIECE(GMZ,U,8))<55
- WRITE $PIECE(GMZ,U,8),!
- +3 IF '$TEST
- SET STR=$PIECE(GMZ,U,8)
- SET COL=45
- DO WRAP
- WRITE !
- +4 QUIT
- WRAP ; Controls wrap-around feature for comments, etc.
- +1 SET TX=$FIND(STR," ",COL)
- WRITE $EXTRACT(STR,1,TX-1),!
- +2 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE ?21,$EXTRACT(STR,TX,$LENGTH(STR))
- +3 QUIT
- EN ; Dietetic Encounters
- +1 SET CNTR=$SELECT(+($GET(GMTSNDM))>0:+($GET(GMTSNDM)),1:99999)
- if '$DATA(^UTILITY($JOB,"EN"))
- QUIT
- +2 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE !,"DIETETIC ENCOUNTERS:",!
- NEW GMW,GMIDT
- SET GMIDT=GMTS1
- +3 FOR
- SET GMIDT=$ORDER(^UTILITY($JOB,"EN",GMIDT))
- if (GMIDT'>0)!(GMIDT>GMTS2)
- QUIT
- Begin DoDot:1
- +4 SET CNTR=CNTR-1
- IF CNTR<0
- QUIT
- +5 NEW GMZ
- SET GMZ=^UTILITY($JOB,"EN",GMIDT,0)
- +6 SET X=+$PIECE(GMZ,U)
- DO REGDT4^GMTSU
- SET STRT=X
- +7 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE STRT,?12,$PIECE(GMZ,U,2),!
- +8 IF $PIECE(GMZ,U,3)]""
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE ?6,$PIECE(GMZ,U,3),!
- +9 IF $PIECE(GMZ,U,4)]""
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE ?6,$PIECE(GMZ,U,4),!
- +10 IF $DATA(^UTILITY($JOB,"NA",GMIDT))
- Begin DoDot:2
- +11 ;I $G(^UTILITY($J,"NA",GMIDT,1)) D CKP^GMTSUP Q:$D(GMTSQIT) W ?6,$G(^UTILITY($J,"NA",GMIDT,1)),!
- +12 ;I $G(^UTILITY($J,"NA",GMIDT,3)) D CKP^GMTSUP Q:$D(GMTSQIT) W ?6,"Comments:",!
- +13 NEW I
- SET I=0
- FOR
- SET I=$ORDER(^UTILITY($JOB,"NA",GMIDT,I))
- if 'I
- QUIT
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE ?6,$GET(^UTILITY($JOB,"NA",GMIDT,I)),!
- End DoDot:2
- End DoDot:1
- +14 QUIT