source: WorldVistAEHR/trunk/r/DIETETICS-FH/FHMTK8.m@ 738

Last change on this file since 738 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 6.6 KB
RevLine 
[613]1FHMTK8 ; HIOFO/SS - DIET PATTERN RELATED UPDATES ;02/22/01 09:02
2 ;;5.5;DIETETICS;;Jan 28, 2005
3 ;
4SO ;check and update Stand.Orders,called from FHMTK7
5 N FH S FH=$$DOSO(FHDFN,ADM)
6 Q
7 ;
8DOSO(FHDFN,FHADM) ;check/update SO
9 ;
10 N FHMX,FHCNT,FHPSO,FHS1,FH,FHDP
11 S FHDP=$$CURDT(FHDFN,FHADM) ;current DietPattr
12 ;1)for patterns edited - update
13 ;2)if no pattern/deleted (FHDP=-1) -cancel all diet related
14 I FHDP'<0 Q:'$D(^TMP($J,+FHDP)) 0
15 S FHCNT=0
16 F FH=0:0 S FH=$O(^FHPT("ASP",FHDFN,FHADM,FH)) Q:FH<1 D
17 . S FHS1=$G(^FHPT(FHDFN,"A",FHADM,"SP",FH,0))
18 . I $P(FHS1,"^",9)="Y" S FHCNT=FHCNT+1,FHPSO("C",FH)=FHS1
19 Q $$CHKSO(FHDP,.FHPSO) ;0-no changes,1-changes
20 ;
21CHKSO(FHDT,FHCSO) ;compares SO of diet patterns(FHDT)
22 ;and patient (FHCSO)
23 N FHML,FH,FHSO,FHCNT2,FH1,FH2
24 S FHCNT2=0
25 F FHML="B","N","E" D ;-thru diff meals
26 . S FH1=0 ;----thru diet pattern SO
27 . F S FH1=$O(^FH(111.1,FHDT,FHML_"S",FH1)) Q:+FH1=0 D
28 .. S FHCNT2=FHCNT2+1
29 .. S FHCSO("N",FHCNT2)=FHML_"^"_^FH(111.1,FHDT,FHML_"S",FH1,0) ;dietpat
30 .. S FH2=0 ;-----thru patient's diet related SOrders
31 .. F S FH2=$O(FHCSO("C",FH2)) Q:+FH2=0 D Q:+FH2=0
32 ... Q:$P(FHCSO("C",FH2),"^",3)'=FHML ;diff meal
33 ... I $P(FHCSO("C",FH2),"^",2)=+$P(FHCSO("N",FHCNT2),"^",2) D S FH2=0
34 .... I $P(FHCSO("C",FH2),"^",8)'=$P(FHCSO("N",FHCNT2),"^",3) S FHCSO("U",FH2)=FHCSO("C",FH2),$P(FHCSO("U",FH2),"^",8)=$P(FHCSO("N",FHCNT2),"^",3)
35 .... K FHCSO("N",FHCNT2),FHCSO("C",FH2) Q
36 ;FHCSO contains info for update
37 ;subscripts mean: "N"-insert,"U"-change amount,"C"-cancel
38 I $D(FHCSO) D UPDTSO(FHDFN,FHADM,.FHCSO) Q 1 ; updated
39 Q 0 ;no changes
40 ;
41UPDTSO(FHDFN,FHADM,FHUCSO) ;update Standing orders.
42 ;FHUCSO-array(see CHKSO for format)
43 N FHNOW,FH,FHNEW
44 ;D PATNAME^FHOMUTL I DFN="" Q ;for ^FHORX
45 ;I '$D(DFN) N DFN S DFN=FHDFN ;for ^FHORX
46 I '$D(ADM) N ADM S ADM=FHADM
47 D NOW^%DTC S FHNOW=%
48 I '$D(DUZ) W !,"Unknown user" Q
49 ; cancel
50 S FH=0 F S FH=$O(FHUCSO("C",FH)) Q:+FH=0 D
51 . D CANCSO
52 ; update
53 S FH=0 F S FH=$O(FHUCSO("U",FH)) Q:+FH=0 D
54 . D CANCSO
55 . S FHNEW=$$ADDSO(FHDFN,FHADM,$P(FHUCSO("U",FH),"^",3),$P(FHUCSO("U",FH),"^",2),$P(FHUCSO("U",FH),"^",8)) S EVT="S^O^"_FHNEW D ^FHORX
56 ; add new
57 S FH=0 F S FH=$O(FHUCSO("N",FH)) Q:+FH=0 D
58 . S FHNEW=$$ADDSO(FHDFN,FHADM,$P(FHUCSO("N",FH),"^",1),$P(FHUCSO("N",FH),"^",2),$P(FHUCSO("N",FH),"^",3)) S EVT="S^O^"_FHNEW D ^FHORX
59 Q
60 ;
61CANCSO ;cancel SO
62 S $P(^FHPT(FHDFN,"A",FHADM,"SP",FH,0),"^",6,7)=FHNOW_"^"_DUZ
63 K ^FHPT("ASP",FHDFN,FHADM,FH)
64 S EVT="S^C^"_FH D ^FHORX ;file event
65 Q
66 ;
67ADDSO(FHDFN,FHADM,FHML,FHSO,FHN) ; Add Standing Order
68 N FHX,FH
69 S FH=0
70AGN L +^FHPT(FHDFN,"A",FHADM,"SP",0)
71 I '$D(^FHPT(FHDFN,"A",FHADM,"SP",0)) S ^FHPT(FHDFN,"A",FHADM,"SP",0)="^115.08^^"
72 S FHX=^FHPT(FHDFN,"A",FHADM,"SP",0),FH=$P(FHX,"^",3)+1,^(0)=$P(FHX,"^",1,2)_"^"_FH_"^"_($P(FHX,"^",4)+1)
73 L -^FHPT(FHDFN,"A",FHADM,"SP",0)
74 G:$D(^FHPT(FHDFN,"A",FHADM,"SP",FH)) AGN
75 S ^FHPT(FHDFN,"A",FHADM,"SP",FH,0)=FH_"^"_FHSO_"^"_FHML_"^"_FHNOW_"^"_DUZ_"^^^"_FHN_"^Y",^FHPT("ASP",FHDFN,FHADM,FH)=""
76 Q FH
77 ;
78 ;--------- Suppl Feedings --------------------
79SF ;check/update diet related SF,called from FHMTK7
80 D DOSF(FHDFN,ADM)
81 Q
82DOSF(FHDFN,FHADM) ;check/update SF
83 ;FHDFN-patient,FHADM-admission
84 N FHDSF,FH,FHPSF
85 ;current DietPattr (DP)'s
86 S FH=$$CURDT(FHDFN,FHADM)
87 ;update only for patterns edited
88 I FH'<0 Q:'$D(^TMP($J,+FH))
89 ;DietPattr's SF menu (ien of 118.1)
90 S FHDSF=$P($G(^FH(111.1,FH,0)),"^",8)
91 ;Patient's SF menu info
92 ;CURRENT seq# of SF MENU entered via SF menu option
93 S FHPSF("N")=$P($G(^FHPT(FHDFN,"A",FHADM,0)),"^",7)
94 S FHPSF("E")=$S(FHPSF("N")="":1,1:0) ;1-if cancelled Explicitly
95 ; if not cancelled Explicitly it still can be entered explicitly
96 ; as well as via diet pattern
97 ; pick up SF seq# from subfile
98 S:FHPSF("E")=1 FHPSF("N")=$P($G(^FHPT(FHDFN,"A",FHADM,"SF",0)),"^",3)
99 ;get SF info
100 S FHPSF=$G(^FHPT(FHDFN,"A",FHADM,"SF",+FHPSF("N"),0))
101 ;if it is expired or cancelled
102 S FHPSF("C")=$S($P(FHPSF,"^",32)="":0,1:1)
103 ;if INDIVIDUALIZED - do nothing
104 Q:+$P(FHPSF,"^",4)=1
105 ;if it is not diet related or if it entered Explicitly via SF menu
106 ;and diet pattern has no SF menu - then do nothing
107 I $P(FHPSF,"^",34)'="Y" Q:FHDSF=""
108 I FHPSF("E")=1 Q:FHDSF=""
109 D UPDSF(FHDFN,FHADM,FHDSF,.FHPSF)
110 Q
111 ;
112UPDSF(FHDFN,FHADM,FHSF,FHPSF) ;updates diet related Suppl.Feed.
113 N FHX,FHNO,FHPNO,FHPNN,FHNOW
114 D NOW^%DTC S FHNOW=%
115 ;D PATNAME^FHOMUTL I DFN="" Q ;for ^FHORX
116 ;I '$D(DFN) N DFN S DFN=FHDFN ;for ^FHORX
117 I '$D(ADM) N ADM S ADM=FHADM
118 I '$D(DUZ) W !,"Unknown user" Q
119 ;if SF is diet related & diet pattr doesn't have SF - cancel it
120 I FHSF="" S FHNO(0)=+FHPSF("N") D:FHNO(0)>0 CANCSF Q
121 ;Diet.Pattr's SFmenu items
122 S FHPNO=$G(^FH(118.1,+FHSF,1)) Q:FHPNO=""
123 ;if no patient SF menu - add
124 G:+FHPSF("N")=0!(FHPSF("C")=1) CONT
125 ;if diffr SF menu - change it
126 G:+$P(FHPSF,"^",4)'=+FHSF CONT
127 ;If SF menu and its content are the same - do nothing
128 Q:$P(FHPSF,"^",5,29)=FHPNO
129 ;cancel current and add new
130CONT S FHPNN="^"_FHNOW_"^"_DUZ_"^"_FHSF_"^"_FHPNO
131 ;create new record
132TRYSF L +^FHPT(FHDFN,"A",FHADM,"SF",0)
133 I '$D(^FHPT(FHDFN,"A",FHADM,"SF",0)) S ^FHPT(FHDFN,"A",FHADM,"SF",0)="^115.07^^"
134 S FHX=^FHPT(FHDFN,"A",FHADM,"SF",0),FHNO(0)=+$P(FHX,"^",3),FHNO=FHNO(0)+1,^(0)=$P(FHX,"^",1,2)_"^"_FHNO_"^"_($P(FHX,"^",4)+1)
135 L -^FHPT(FHDFN,"A",FHADM,"SF",0) I $D(^FHPT(FHDFN,"A",FHADM,"SF",FHNO)) G TRYSF
136 ;add new
137 S ^FHPT(FHDFN,"A",FHADM,"SF",FHNO,0)=FHNO_"^"_$P(FHPNN,"^",2,99)
138 ;when new one is OK - cancel previous & file event
139 D CANCSF
140 ;update # and put timestamp for new record
141 S $P(^FHPT(FHDFN,"A",FHADM,0),"^",7)=FHNO
142 S:FHNO $P(^FHPT(FHDFN,"A",FHADM,"SF",FHNO,0),"^",30,31)=FHNOW_"^"_DUZ
143 ;set diet related for new record
144 S:FHNO $P(^FHPT(FHDFN,"A",FHADM,"SF",FHNO,0),"^",34)="Y"
145 ;file event
146 S EVT="F^O^"_FHNO D ^FHORX
147 Q
148 ;cancel previous & file event
149CANCSF I FHNO(0)'=0&(FHPSF("C")=0) D
150 . S $P(^FHPT(FHDFN,"A",FHADM,"SF",FHNO(0),0),"^",32,33)=FHNOW_"^"_DUZ
151 . S $P(^FHPT(FHDFN,"A",FHADM,0),"^",7)=""
152 . S EVT="F^C^"_FHNO(0) D ^FHORX
153 Q
154 ;
155CURDT(FHDFN,FHADM) ;get current patient's diet pattern ien of 111.1
156 N FHDT,FHOR,FHZ
157 S FHDT=$P($G(^FHPT(FHDFN,"A",FHADM,0)),"^",2) Q:FHDT<1 -1
158 S FHZ=$G(^FHPT(FHDFN,"A",FHADM,"DI",FHDT,0)),FHOR=$P(FHZ,"^",2,6) I "^^^^"[FHOR Q -1
159 S FHDT=$O(^FH(111.1,"AB",FHOR,0)) Q:FHDT="" -1 ;doesn't exist
160 Q FHDT
161 ;
162NEWTMP ;save original state before editing
163 Q:$O(^TMP($J,DA,""))'="" ;repeated editing
164 M ^TMP($J,DA)=^FH(111.1,DA)
165 Q
166 ;
167CLEANTMP ;
168 N FHA1,FHB1,FHDA
169 S FHDA=""
170 F S FHDA=$O(^TMP($J,FHDA)) Q:+FHDA=0 D
171 . S FHA1="^TMP($J,FHDA,"""")",FHB1="^FH(111.1,FHDA,"""")"
172 . F Q:$$FETCH(.FHA1,$J,FHDA)'=$$FETCH(.FHB1,111.1,FHDA) I FHA1="" K ^TMP($J,FHDA) Q
173 Q
174 ;
175FETCH(FHX,FHSUB,FHDP) ;
176 S FHX=$Q(@FHX)
177 I $P($P(FHX,",",1),"(",2)'=FHSUB!($P(FHX,",",2)'=FHDP) S FHX="" Q ""
178 Q $P(FHX,",",2,99)_"="_@FHX
179 ;
Note: See TracBrowser for help on using the repository browser.