iSharkFly-Open
/
VistA-WorldVistAEHR
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
VistA-WorldVistAEHR/r/DIETETICS-FH/FHOMRBLD.m

211 lines
8.1 KiB
Mathematica
Raw Blame History

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
Reference in New Issue View Git Blame Copy Permalink