- 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 Mar 13, 2025@20:57:32 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
