FHOMRBLD ;Hines OIFO/RVD-OUTPATIENT REPORT UTILITY ;2/03/04 10:05
;;5.5;DIETETICS;;Jan 28, 2005
;
;RVD 2/3/04 - modified for Outpatient Meals
;
;ENTRY POINTS:
; GETRM - get outpatient recurring meals data from starting dt.
; GETSM - get outpatient special meals data from starting dt.
;
GETRM(FHSDT,FHCOM,FHLOC,FHRDFN) ;get special recurring data.
;input variables:
; FHSDT = starting date
; FHCOM = IEN of communication office, 'ALL' for all.
; = if NULL, considered 'ALL'
; FHLOC = IEN of location, 'ALL' for all.
; = if NULL, considered 'ALL'
; FHRDFN = IEN of NUTRITION PERSON, 'ALL' for all.
; = if NULL, considered 'ALL'
;
;ouput:
; ^TMP($J,"OP","R",COMMUNICATION OFF,NUTRITION LOCATION,PATIENT,DTE)
; = for outpatient recurring meals
;
;contents of ^TMP($J global:
; Piece 1 = patient DFN(IEN in file #115)
; Piece 2 = recurring meals IEN
; Piece 3 = recurring date/time
; Piece 4 = diet
; Piece 5 = meal
; Piece 6 = bagged meal
; Piece 7 = meal plan order number
; Piece 8 = ADDITIONAL ORDER TEXT
; Piece 9 = ADDITIONAL ORDER CLERK
; Piece 10 = ADDITIONAL ORDER DATE AND TIME
; Piece 11 = EARLY/LATE TRAY TIME
; Piece 12 = EARLY/LATE TRAY BAGGED MEAL
; Piece 13 = EARLY/LATE TRAY CLERK
; Piece 14 = EARLY/LATE TRAY ENTRY DATE
; Piece 15 = TUBEFEEDING COMMENT
; Piece 16 = TF TOTAL CC'S
; Piece 17 = TF TOTAL KCALS/DAY
; Piece 18 = SERVICE (T,C,D or combination of 3)
; Piece 19 = Status
;
;error:
; ^TMP($J,"OP","ER") = error message
K ^TMP($J,"OP","R")
D NEWVAR
I '$O(^FHPT("RM",FHSDT)) S ^TMP($J,"OP","ER")="NO RECURRING MEALS FOR THIS DATE RANGE" Q
S:FHLOC="" FHLOC="ALL"
S:FHCOM="" FHCOM="ALL"
S:FHRDFN="" FHRDFN="ALL"
F FHSMDT=FHSDT:0 S FHSMDT=$O(^FHPT("RM",FHSMDT)) Q:FHSMDT'>0 D
.F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",FHSMDT,FHDFN)) Q:FHDFN'>0 D
..F FHIN=0:0 S FHIN=$O(^FHPT("RM",FHSMDT,FHDFN,FHIN)) Q:FHIN'>0 D
...I $G(FHRDFN),(FHRDFN'=FHDFN) Q ;quit entry is different.
...S (FHLCOMN,FHLCOM,FHLOCN,FHPTNM,FHDIET,FHTCD)=""
...S FHNODE=$G(^FHPT(FHDFN,"OP",FHIN,0))
...S FHD=$P(FHNODE,U,1)
...D PATNAME^FHOMUTL S FHPTNM=$E(FHPTNM,1,18)
...S:'$D(FHPTNM) FHPTNM="***"
...S:FHPTNM="" FHPTNM="***"
...S FHD=$$FMTE^XLFDT(FHSMDT,"P")
...S FHD=$E(FHD,1,12)
...S FHLPT=$P(FHNODE,U,3)
...I $G(FHLOC),FHLOC'=FHLPT Q ;quit if location is not the same
...S:$G(FHLPT) FHLCOM=$P($G(^FH(119.6,FHLPT,0)),U,8)
...I $G(FHCOM),FHCOM'=FHLCOM Q ;quit if not same communication office
...S:$G(FHLCOM) FHLCOMN=$P($G(^FH(119.73,FHLCOM,0)),U,1)
...S:FHLCOMN="" FHLCOMN="***"
...I $G(FHLPT) D
....S FHLOCN=$P($G(^FH(119.6,FHLPT,0)),U,1)
....S:$P($G(^FH(119.6,FHLPT,0)),U,5) FHTCD=FHTCD_"T"
....S:$P($G(^FH(119.6,FHLPT,0)),U,6) FHTCD=FHTCD_"C"
....S:$P($G(^FH(119.6,FHLPT,0)),U,7) FHTCD=FHTCD_"D"
...S:FHLOCN="" FHLOCN="***"
...S FHDPT=$P(FHNODE,U,2) S:FHDPT="" FHDPT=$P(FHNODE,U,7)
...S:FHDPT="" FHDPT=$P(FHNODE,U,8) S:FHDPT="" FHDPT=$P(FHNODE,U,9)
...S:FHDPT="" FHDPT=$P(FHNODE,U,10) S:FHDPT="" FHDPT=$P(FHNODE,U,11)
...S:$G(FHDPT) FHDIET=$P($G(^FH(111,FHDPT,0)),U,1)
...S:FHDIET="" FHDIET="***"
...S FHMEAL=$P(FHNODE,U,4)
...S:FHMEAL="" FHMEAL=$P(FHNODE,U,7)
...S:FHMEAL="" FHMEAL=$P(FHNODE,U,8)
...S:FHMEAL="" FHMEAL=$P(FHNODE,U,9)
...S:FHMEAL="" FHMEAL=$P(FHNODE,U,10)
...S:FHMEAL="" FHMEAL=$P(FHNODE,U,11)
...S FHBAGM=$P(FHNODE,U,5)
...S FHMPO=$P(FHNODE,U,6)
...S FHMPO=$E(FHMPO,1,70)
...S FHSTAT=$P(FHNODE,U,15)
...S (FHADO,FHADOC,FHADODT,FHELT,FHELTB)=""
...S (FHELTC,FHELTED,FHTFC,FHTFTC,FHTFTK)=""
...I $D(^FHPT(FHDFN,"OP",FHIN,1)) D
....S FHEL=$G(^FHPT(FHDFN,"OP",FHIN,1))
....S FHADO=$P(FHEL,U,1)
....S FHADOC=$P(FHEL,U,2)
....I $G(FHADOC),($D(^VA(200,FHADOC,0))) S FHADOC=$P(^VA(200,FHADOC,0),U,1)
....S FHADDT=$P(FHEL,U,3)
...I $D(^FHPT(FHDFN,"OP",FHIN,2)) D
....S FHEL2=$G(^FHPT(FHDFN,"OP",FHIN,2))
....S FHELT=$P(FHEL2,U,1)
....S FHELTB=$P(FHEL2,U,2)
....S FHELTC=$P(FHEL2,U,3)
....S FHELTED=$P(FHEL2,U,4)
...I $D(^FHPT(FHDFN,"OP",FHIN,3)) D
....S FHEL3=$G(^FHPT(FHDFN,"OP",FHIN,3))
....S FHTFC=$P(FHEL3,U,1)
....S FHTFTC=$P(FHEL3,U,2)
....S FHTFTK=$P(FHEL3,U,3)
...S FHDAT=FHDFN_"^"_FHD_"^"_FHDIET_"^"_FHMEAL_"^"_FHBAGM_"^"_FHMPO
...S FHDAT=FHDAT_"^"_FHADO_"^"_FHADOC_"^"_FHADODT_"^"_FHELT_"^"_FHELTB
...S FHDAT=FHDAT_"^"_FHELTC_"^"_FHELTED_"^"_FHTFC_"^"_FHTFTC_"^"_FHTFTK
...S ^TMP($J,"OP","R",FHLCOMN,FHLOCN,FHPTNM,FHSMDT)=FHDAT_"^"_FHTCD_"^"_FHSTAT
Q
;
;
GETSM(FHSDT,FHCOM,FHLOC,FHSDFN) ;get special meals data.
;input variables:
; FHSDT = starting date
; FHCOM = IEN of communication office, 'ALL' for all.
; = if NULL, considered 'ALL'
; FHLOC = IEN of location, 'ALL' for all.
; = if NULL, considered 'ALL'
; FHSDFN = IEN of file #115, 'ALL' for all.
; = if NULL, considered 'ALL'
;
;ouput:
; ^TMP($J,"OP","S",COMMUNICATION OFF,NUTRITION LOCATION,PATIENT,DTE)
; = for outpatient special meals
;
;contents of ^TMP($J global:
; Piece 1 = patient DFN
; Piece 2 = special meal date/time
; Piece 3 = status
; Piece 4 = diet
; Piece 5 = requestor
; Piece 6 = authorizor
; Piece 7 = authorize/deny date/time
; Piece 8 = comment
; Piece 9 = meal
; Piece 10 = early/late tray time
; Piece 11 = early/late tray bagged meal
; Piece 12 = early/late tray clerk
; Piece 13 = SERVICE (T,C,D or combination of 3)
;
;error:
; ^TMP($J,"OP","ER")
K ^TMP($J,"OP","S")
D NEWVAR
S FHSDT=FHSDT-.000001
I '$O(^FHPT("SM",FHSDT)) S ^TMP($J,"OP","ER")="NO SPECIAL MEALS FOR THIS DATE RANGE" Q
S:FHLOC="" FHLOC="ALL"
S:FHCOM="" FHCOM="ALL"
S:FHSDFN="" FHSDFN="ALL"
S FHS="ACDP"
F FHSMDT=FHSDT:0 S FHSMDT=$O(^FHPT("SM",FHSMDT)) Q:FHSMDT'>0 D
.F FHDFN=0:0 S FHDFN=$O(^FHPT("SM",FHSMDT,FHDFN)) Q:FHDFN'>0 D
..I $G(FHSDFN),(FHSDFN'=FHDFN) Q
..S (FHLCOMN,FHLCOM,FHLOCN,FHPTNM,FHDIET,FHTCD)=""
..S FHNODE=$G(^FHPT(FHDFN,"SM",FHSMDT,0))
..S FHSTAT=$P(FHNODE,U,2)
..I FHS'[FHSTAT Q
..S FHSTAT=$S(FHSTAT="P":"PENDING",FHSTAT="A":"AUTHORIZED",FHSTAT="D":"DENIED",1:"CANCELLED")
..D PATNAME^FHOMUTL S FHPTNM=$E(FHPTNM,1,18)
..S:FHPTNM="" FHPTNM="***"
..S FHD=$$FMTE^XLFDT(FHSMDT,"P")
..S FHD=$E(FHD,1,12)
..S FHSTAT=$P(FHNODE,U,2)
..S FHLPT=$P(FHNODE,U,3)
..I $G(FHLOC),FHLOC'=FHLPT Q
..S:$G(FHLPT) FHLCOM=$P($G(^FH(119.6,FHLPT,0)),U,8)
..I $G(FHCOM),FHCOM'=FHLCOM Q ;quit if d same communication office
..S:$G(FHLCOM) FHLCOMN=$P($G(^FH(119.73,FHLCOM,0)),U,1)
..S:FHLCOMN="" FHLCOMN="***"
..I $G(FHLPT) D
...S FHLOCN=$P($G(^FH(119.6,FHLPT,0)),U,1)
...S:$P($G(^FH(119.6,FHLPT,0)),U,5) FHTCD=FHTCD_"T"
...S:$P($G(^FH(119.6,FHLPT,0)),U,6) FHTCD=FHTCD_"C"
...S:$P($G(^FH(119.6,FHLPT,0)),U,7) FHTCD=FHTCD_"D"
..S:FHLOCN="" FHLOCN="***"
..S FHDPT=$P(FHNODE,U,4)
..S:$G(FHDPT) FHDIET=$P($G(^FH(111,FHDPT,0)),U,1)
..S:FHDIET="" FHDIET="***"
..S (FHAUTR,FHREQ)=""
..S FHCOMM=$P(FHNODE,U,8)
..S FHMEAL=$P(FHNODE,U,9)
..S FHADDT=$P(FHNODE,U,7)
..S FHAUTR=$P(FHNODE,U,6)
..S FHREQ=$P(FHNODE,U,5)
..S:$L(FHCOMM)>70 FHCOMM=$E(FHCOMM,1,70)
..I $G(FHAUTR),($D(^VA(200,FHAUTR,0))) S FHAUTR=$P(^VA(200,FHAUTR,0),U,1)
..I $G(FHREQ),($D(^VA(200,FHREQ,0))) S FHREQ=$P(^VA(200,FHREQ,0),U,1)
..S (FHELT,FHELBG,FHELC)=""
..I $D(^FHPT(FHDFN,"SM",FHSMDT,1)) D
...S FHEL=$G(^FHPT(FHDFN,"SM",FHSMDT,1))
...S FHELT=$P(FHEL,U,1)
...S FHELBG=$P(FHEL,U,2)
...S FHELC=$P(FHEL,U,3)
..S FHDAT=FHDFN_"^"_FHD_"^"_FHSTAT_"^"_FHDIET_"^"_FHREQ
..S FHDAT=FHDAT_"^"_FHAUTR_"^"_FHADDT_"^"_FHCOMM
..S FHDAT=FHDAT_"^"_FHMEAL_"^"_FHELT_"^"_FHELBG_"^"_FHELC_"^"_FHTCD
..S ^TMP($J,"OP","S",FHLCOMN,FHLOCN,FHPTNM,FHSMDT)=FHDAT
Q
;
NEWVAR ;new all variables.
N FHPTNM,FHD,FHDIET,FHMEAL,FHELTT,FHELBG,FHDAT,FHSTAT,FHLPT
N FHAGE,FHCH,FHCL,FHDOB,FHGMDT,FHML,FHNODE,FHPCZN,FHSEX,FHSSN,FILE
N FHDAT,FHDPT,FHEL,FHLPT,FHS,FHSMDT,FHSTAT,FHNN,FH
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHOMRBLD 8484 printed Apr 09, 2024@20:52:45 Page 2
FHOMRBLD ;Hines OIFO/RVD-OUTPATIENT REPORT UTILITY ;2/03/04 10:05
+1 ;;5.5;DIETETICS;;Jan 28, 2005
+2 ;
+3 ;RVD 2/3/04 - modified for Outpatient Meals
+4 ;
+5 ;ENTRY POINTS:
+6 ; GETRM - get outpatient recurring meals data from starting dt.
+7 ; GETSM - get outpatient special meals data from starting dt.
+8 ;
GETRM(FHSDT,FHCOM,FHLOC,FHRDFN) ;get special recurring data.
+1 ;input variables:
+2 ; FHSDT = starting date
+3 ; FHCOM = IEN of communication office, 'ALL' for all.
+4 ; = if NULL, considered 'ALL'
+5 ; FHLOC = IEN of location, 'ALL' for all.
+6 ; = if NULL, considered 'ALL'
+7 ; FHRDFN = IEN of NUTRITION PERSON, 'ALL' for all.
+8 ; = if NULL, considered 'ALL'
+9 ;
+10 ;ouput:
+11 ; ^TMP($J,"OP","R",COMMUNICATION OFF,NUTRITION LOCATION,PATIENT,DTE)
+12 ; = for outpatient recurring meals
+13 ;
+14 ;contents of ^TMP($J global:
+15 ; Piece 1 = patient DFN(IEN in file #115)
+16 ; Piece 2 = recurring meals IEN
+17 ; Piece 3 = recurring date/time
+18 ; Piece 4 = diet
+19 ; Piece 5 = meal
+20 ; Piece 6 = bagged meal
+21 ; Piece 7 = meal plan order number
+22 ; Piece 8 = ADDITIONAL ORDER TEXT
+23 ; Piece 9 = ADDITIONAL ORDER CLERK
+24 ; Piece 10 = ADDITIONAL ORDER DATE AND TIME
+25 ; Piece 11 = EARLY/LATE TRAY TIME
+26 ; Piece 12 = EARLY/LATE TRAY BAGGED MEAL
+27 ; Piece 13 = EARLY/LATE TRAY CLERK
+28 ; Piece 14 = EARLY/LATE TRAY ENTRY DATE
+29 ; Piece 15 = TUBEFEEDING COMMENT
+30 ; Piece 16 = TF TOTAL CC'S
+31 ; Piece 17 = TF TOTAL KCALS/DAY
+32 ; Piece 18 = SERVICE (T,C,D or combination of 3)
+33 ; Piece 19 = Status
+34 ;
+35 ;error:
+36 ; ^TMP($J,"OP","ER") = error message
+37 KILL ^TMP($JOB,"OP","R")
+38 DO NEWVAR
+39 IF '$ORDER(^FHPT("RM",FHSDT))
SET ^TMP($JOB,"OP","ER")="NO RECURRING MEALS FOR THIS DATE RANGE"
QUIT
+40 if FHLOC=""
SET FHLOC="ALL"
+41 if FHCOM=""
SET FHCOM="ALL"
+42 if FHRDFN=""
SET FHRDFN="ALL"
+43 FOR FHSMDT=FHSDT:0
SET FHSMDT=$ORDER(^FHPT("RM",FHSMDT))
if FHSMDT'>0
QUIT
Begin DoDot:1
+44 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("RM",FHSMDT,FHDFN))
if FHDFN'>0
QUIT
Begin DoDot:2
+45 FOR FHIN=0:0
SET FHIN=$ORDER(^FHPT("RM",FHSMDT,FHDFN,FHIN))
if FHIN'>0
QUIT
Begin DoDot:3
+46 ;quit entry is different.
IF $GET(FHRDFN)
IF (FHRDFN'=FHDFN)
QUIT
+47 SET (FHLCOMN,FHLCOM,FHLOCN,FHPTNM,FHDIET,FHTCD)=""
+48 SET FHNODE=$GET(^FHPT(FHDFN,"OP",FHIN,0))
+49 SET FHD=$PIECE(FHNODE,U,1)
+50 DO PATNAME^FHOMUTL
SET FHPTNM=$EXTRACT(FHPTNM,1,18)
+51 if '$DATA(FHPTNM)
SET FHPTNM="***"
+52 if FHPTNM=""
SET FHPTNM="***"
+53 SET FHD=$$FMTE^XLFDT(FHSMDT,"P")
+54 SET FHD=$EXTRACT(FHD,1,12)
+55 SET FHLPT=$PIECE(FHNODE,U,3)
+56 ;quit if location is not the same
IF $GET(FHLOC)
IF FHLOC'=FHLPT
QUIT
+57 if $GET(FHLPT)
SET FHLCOM=$PIECE($GET(^FH(119.6,FHLPT,0)),U,8)
+58 ;quit if not same communication office
IF $GET(FHCOM)
IF FHCOM'=FHLCOM
QUIT
+59 if $GET(FHLCOM)
SET FHLCOMN=$PIECE($GET(^FH(119.73,FHLCOM,0)),U,1)
+60 if FHLCOMN=""
SET FHLCOMN="***"
+61 IF $GET(FHLPT)
Begin DoDot:4
+62 SET FHLOCN=$PIECE($GET(^FH(119.6,FHLPT,0)),U,1)
+63 if $PIECE($GET(^FH(119.6,FHLPT,0)),U,5)
SET FHTCD=FHTCD_"T"
+64 if $PIECE($GET(^FH(119.6,FHLPT,0)),U,6)
SET FHTCD=FHTCD_"C"
+65 if $PIECE($GET(^FH(119.6,FHLPT,0)),U,7)
SET FHTCD=FHTCD_"D"
End DoDot:4
+66 if FHLOCN=""
SET FHLOCN="***"
+67 SET FHDPT=$PIECE(FHNODE,U,2)
if FHDPT=""
SET FHDPT=$PIECE(FHNODE,U,7)
+68 if FHDPT=""
SET FHDPT=$PIECE(FHNODE,U,8)
if FHDPT=""
SET FHDPT=$PIECE(FHNODE,U,9)
+69 if FHDPT=""
SET FHDPT=$PIECE(FHNODE,U,10)
if FHDPT=""
SET FHDPT=$PIECE(FHNODE,U,11)
+70 if $GET(FHDPT)
SET FHDIET=$PIECE($GET(^FH(111,FHDPT,0)),U,1)
+71 if FHDIET=""
SET FHDIET="***"
+72 SET FHMEAL=$PIECE(FHNODE,U,4)
+73 if FHMEAL=""
SET FHMEAL=$PIECE(FHNODE,U,7)
+74 if FHMEAL=""
SET FHMEAL=$PIECE(FHNODE,U,8)
+75 if FHMEAL=""
SET FHMEAL=$PIECE(FHNODE,U,9)
+76 if FHMEAL=""
SET FHMEAL=$PIECE(FHNODE,U,10)
+77 if FHMEAL=""
SET FHMEAL=$PIECE(FHNODE,U,11)
+78 SET FHBAGM=$PIECE(FHNODE,U,5)
+79 SET FHMPO=$PIECE(FHNODE,U,6)
+80 SET FHMPO=$EXTRACT(FHMPO,1,70)
+81 SET FHSTAT=$PIECE(FHNODE,U,15)
+82 SET (FHADO,FHADOC,FHADODT,FHELT,FHELTB)=""
+83 SET (FHELTC,FHELTED,FHTFC,FHTFTC,FHTFTK)=""
+84 IF $DATA(^FHPT(FHDFN,"OP",FHIN,1))
Begin DoDot:4
+85 SET FHEL=$GET(^FHPT(FHDFN,"OP",FHIN,1))
+86 SET FHADO=$PIECE(FHEL,U,1)
+87 SET FHADOC=$PIECE(FHEL,U,2)
+88 IF $GET(FHADOC)
IF ($DATA(^VA(200,FHADOC,0)))
SET FHADOC=$PIECE(^VA(200,FHADOC,0),U,1)
+89 SET FHADDT=$PIECE(FHEL,U,3)
End DoDot:4
+90 IF $DATA(^FHPT(FHDFN,"OP",FHIN,2))
Begin DoDot:4
+91 SET FHEL2=$GET(^FHPT(FHDFN,"OP",FHIN,2))
+92 SET FHELT=$PIECE(FHEL2,U,1)
+93 SET FHELTB=$PIECE(FHEL2,U,2)
+94 SET FHELTC=$PIECE(FHEL2,U,3)
+95 SET FHELTED=$PIECE(FHEL2,U,4)
End DoDot:4
+96 IF $DATA(^FHPT(FHDFN,"OP",FHIN,3))
Begin DoDot:4
+97 SET FHEL3=$GET(^FHPT(FHDFN,"OP",FHIN,3))
+98 SET FHTFC=$PIECE(FHEL3,U,1)
+99 SET FHTFTC=$PIECE(FHEL3,U,2)
+100 SET FHTFTK=$PIECE(FHEL3,U,3)
End DoDot:4
+101 SET FHDAT=FHDFN_"^"_FHD_"^"_FHDIET_"^"_FHMEAL_"^"_FHBAGM_"^"_FHMPO
+102 SET FHDAT=FHDAT_"^"_FHADO_"^"_FHADOC_"^"_FHADODT_"^"_FHELT_"^"_FHELTB
+103 SET FHDAT=FHDAT_"^"_FHELTC_"^"_FHELTED_"^"_FHTFC_"^"_FHTFTC_"^"_FHTFTK
+104 SET ^TMP($JOB,"OP","R",FHLCOMN,FHLOCN,FHPTNM,FHSMDT)=FHDAT_"^"_FHTCD_"^"_FHSTAT
End DoDot:3
End DoDot:2
End DoDot:1
+105 QUIT
+106 ;
+107 ;
GETSM(FHSDT,FHCOM,FHLOC,FHSDFN) ;get special meals data.
+1 ;input variables:
+2 ; FHSDT = starting date
+3 ; FHCOM = IEN of communication office, 'ALL' for all.
+4 ; = if NULL, considered 'ALL'
+5 ; FHLOC = IEN of location, 'ALL' for all.
+6 ; = if NULL, considered 'ALL'
+7 ; FHSDFN = IEN of file #115, 'ALL' for all.
+8 ; = if NULL, considered 'ALL'
+9 ;
+10 ;ouput:
+11 ; ^TMP($J,"OP","S",COMMUNICATION OFF,NUTRITION LOCATION,PATIENT,DTE)
+12 ; = for outpatient special meals
+13 ;
+14 ;contents of ^TMP($J global:
+15 ; Piece 1 = patient DFN
+16 ; Piece 2 = special meal date/time
+17 ; Piece 3 = status
+18 ; Piece 4 = diet
+19 ; Piece 5 = requestor
+20 ; Piece 6 = authorizor
+21 ; Piece 7 = authorize/deny date/time
+22 ; Piece 8 = comment
+23 ; Piece 9 = meal
+24 ; Piece 10 = early/late tray time
+25 ; Piece 11 = early/late tray bagged meal
+26 ; Piece 12 = early/late tray clerk
+27 ; Piece 13 = SERVICE (T,C,D or combination of 3)
+28 ;
+29 ;error:
+30 ; ^TMP($J,"OP","ER")
+31 KILL ^TMP($JOB,"OP","S")
+32 DO NEWVAR
+33 SET FHSDT=FHSDT-.000001
+34 IF '$ORDER(^FHPT("SM",FHSDT))
SET ^TMP($JOB,"OP","ER")="NO SPECIAL MEALS FOR THIS DATE RANGE"
QUIT
+35 if FHLOC=""
SET FHLOC="ALL"
+36 if FHCOM=""
SET FHCOM="ALL"
+37 if FHSDFN=""
SET FHSDFN="ALL"
+38 SET FHS="ACDP"
+39 FOR FHSMDT=FHSDT:0
SET FHSMDT=$ORDER(^FHPT("SM",FHSMDT))
if FHSMDT'>0
QUIT
Begin DoDot:1
+40 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("SM",FHSMDT,FHDFN))
if FHDFN'>0
QUIT
Begin DoDot:2
+41 IF $GET(FHSDFN)
IF (FHSDFN'=FHDFN)
QUIT
+42 SET (FHLCOMN,FHLCOM,FHLOCN,FHPTNM,FHDIET,FHTCD)=""
+43 SET FHNODE=$GET(^FHPT(FHDFN,"SM",FHSMDT,0))
+44 SET FHSTAT=$PIECE(FHNODE,U,2)
+45 IF FHS'[FHSTAT
QUIT
+46 SET FHSTAT=$SELECT(FHSTAT="P":"PENDING",FHSTAT="A":"AUTHORIZED",FHSTAT="D":"DENIED",1:"CANCELLED")
+47 DO PATNAME^FHOMUTL
SET FHPTNM=$EXTRACT(FHPTNM,1,18)
+48 if FHPTNM=""
SET FHPTNM="***"
+49 SET FHD=$$FMTE^XLFDT(FHSMDT,"P")
+50 SET FHD=$EXTRACT(FHD,1,12)
+51 SET FHSTAT=$PIECE(FHNODE,U,2)
+52 SET FHLPT=$PIECE(FHNODE,U,3)
+53 IF $GET(FHLOC)
IF FHLOC'=FHLPT
QUIT
+54 if $GET(FHLPT)
SET FHLCOM=$PIECE($GET(^FH(119.6,FHLPT,0)),U,8)
+55 ;quit if d same communication office
IF $GET(FHCOM)
IF FHCOM'=FHLCOM
QUIT
+56 if $GET(FHLCOM)
SET FHLCOMN=$PIECE($GET(^FH(119.73,FHLCOM,0)),U,1)
+57 if FHLCOMN=""
SET FHLCOMN="***"
+58 IF $GET(FHLPT)
Begin DoDot:3
+59 SET FHLOCN=$PIECE($GET(^FH(119.6,FHLPT,0)),U,1)
+60 if $PIECE($GET(^FH(119.6,FHLPT,0)),U,5)
SET FHTCD=FHTCD_"T"
+61 if $PIECE($GET(^FH(119.6,FHLPT,0)),U,6)
SET FHTCD=FHTCD_"C"
+62 if $PIECE($GET(^FH(119.6,FHLPT,0)),U,7)
SET FHTCD=FHTCD_"D"
End DoDot:3
+63 if FHLOCN=""
SET FHLOCN="***"
+64 SET FHDPT=$PIECE(FHNODE,U,4)
+65 if $GET(FHDPT)
SET FHDIET=$PIECE($GET(^FH(111,FHDPT,0)),U,1)
+66 if FHDIET=""
SET FHDIET="***"
+67 SET (FHAUTR,FHREQ)=""
+68 SET FHCOMM=$PIECE(FHNODE,U,8)
+69 SET FHMEAL=$PIECE(FHNODE,U,9)
+70 SET FHADDT=$PIECE(FHNODE,U,7)
+71 SET FHAUTR=$PIECE(FHNODE,U,6)
+72 SET FHREQ=$PIECE(FHNODE,U,5)
+73 if $LENGTH(FHCOMM)>70
SET FHCOMM=$EXTRACT(FHCOMM,1,70)
+74 IF $GET(FHAUTR)
IF ($DATA(^VA(200,FHAUTR,0)))
SET FHAUTR=$PIECE(^VA(200,FHAUTR,0),U,1)
+75 IF $GET(FHREQ)
IF ($DATA(^VA(200,FHREQ,0)))
SET FHREQ=$PIECE(^VA(200,FHREQ,0),U,1)
+76 SET (FHELT,FHELBG,FHELC)=""
+77 IF $DATA(^FHPT(FHDFN,"SM",FHSMDT,1))
Begin DoDot:3
+78 SET FHEL=$GET(^FHPT(FHDFN,"SM",FHSMDT,1))
+79 SET FHELT=$PIECE(FHEL,U,1)
+80 SET FHELBG=$PIECE(FHEL,U,2)
+81 SET FHELC=$PIECE(FHEL,U,3)
End DoDot:3
+82 SET FHDAT=FHDFN_"^"_FHD_"^"_FHSTAT_"^"_FHDIET_"^"_FHREQ
+83 SET FHDAT=FHDAT_"^"_FHAUTR_"^"_FHADDT_"^"_FHCOMM
+84 SET FHDAT=FHDAT_"^"_FHMEAL_"^"_FHELT_"^"_FHELBG_"^"_FHELC_"^"_FHTCD
+85 SET ^TMP($JOB,"OP","S",FHLCOMN,FHLOCN,FHPTNM,FHSMDT)=FHDAT
End DoDot:2
End DoDot:1
+86 QUIT
+87 ;
NEWVAR ;new all variables.
+1 NEW FHPTNM,FHD,FHDIET,FHMEAL,FHELTT,FHELBG,FHDAT,FHSTAT,FHLPT
+2 NEW FHAGE,FHCH,FHCL,FHDOB,FHGMDT,FHML,FHNODE,FHPCZN,FHSEX,FHSSN,FILE
+3 NEW FHDAT,FHDPT,FHEL,FHLPT,FHS,FHSMDT,FHSTAT,FHNN,FH
+4 QUIT
