FHMTK8 ; HIOFO/SS - DIET PATTERN RELATED UPDATES ;02/22/01 09:02
;;5.5;DIETETICS;;Jan 28, 2005
;
SO ;check and update Stand.Orders,called from FHMTK7
N FH S FH=$$DOSO(FHDFN,ADM)
Q
;
DOSO(FHDFN,FHADM) ;check/update SO
;
N FHMX,FHCNT,FHPSO,FHS1,FH,FHDP
S FHDP=$$CURDT(FHDFN,FHADM) ;current DietPattr
;1)for patterns edited - update
;2)if no pattern/deleted (FHDP=-1) -cancel all diet related
I FHDP'<0 Q:'$D(^TMP($J,+FHDP)) 0
S FHCNT=0
F FH=0:0 S FH=$O(^FHPT("ASP",FHDFN,FHADM,FH)) Q:FH<1 D
. S FHS1=$G(^FHPT(FHDFN,"A",FHADM,"SP",FH,0))
. I $P(FHS1,"^",9)="Y" S FHCNT=FHCNT+1,FHPSO("C",FH)=FHS1
Q $$CHKSO(FHDP,.FHPSO) ;0-no changes,1-changes
;
CHKSO(FHDT,FHCSO) ;compares SO of diet patterns(FHDT)
;and patient (FHCSO)
N FHML,FH,FHSO,FHCNT2,FH1,FH2
S FHCNT2=0
F FHML="B","N","E" D ;-thru diff meals
. S FH1=0 ;----thru diet pattern SO
. F S FH1=$O(^FH(111.1,FHDT,FHML_"S",FH1)) Q:+FH1=0 D
.. S FHCNT2=FHCNT2+1
.. S FHCSO("N",FHCNT2)=FHML_"^"_^FH(111.1,FHDT,FHML_"S",FH1,0) ;dietpat
.. S FH2=0 ;-----thru patient's diet related SOrders
.. F S FH2=$O(FHCSO("C",FH2)) Q:+FH2=0 D Q:+FH2=0
... Q:$P(FHCSO("C",FH2),"^",3)'=FHML ;diff meal
... I $P(FHCSO("C",FH2),"^",2)=+$P(FHCSO("N",FHCNT2),"^",2) D S FH2=0
.... 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)
.... K FHCSO("N",FHCNT2),FHCSO("C",FH2) Q
;FHCSO contains info for update
;subscripts mean: "N"-insert,"U"-change amount,"C"-cancel
I $D(FHCSO) D UPDTSO(FHDFN,FHADM,.FHCSO) Q 1 ; updated
Q 0 ;no changes
;
UPDTSO(FHDFN,FHADM,FHUCSO) ;update Standing orders.
;FHUCSO-array(see CHKSO for format)
N FHNOW,FH,FHNEW
;D PATNAME^FHOMUTL I DFN="" Q ;for ^FHORX
;I '$D(DFN) N DFN S DFN=FHDFN ;for ^FHORX
I '$D(ADM) N ADM S ADM=FHADM
D NOW^%DTC S FHNOW=%
I '$D(DUZ) W !,"Unknown user" Q
; cancel
S FH=0 F S FH=$O(FHUCSO("C",FH)) Q:+FH=0 D
. D CANCSO
; update
S FH=0 F S FH=$O(FHUCSO("U",FH)) Q:+FH=0 D
. D CANCSO
. 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
; add new
S FH=0 F S FH=$O(FHUCSO("N",FH)) Q:+FH=0 D
. 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
Q
;
CANCSO ;cancel SO
S $P(^FHPT(FHDFN,"A",FHADM,"SP",FH,0),"^",6,7)=FHNOW_"^"_DUZ
K ^FHPT("ASP",FHDFN,FHADM,FH)
S EVT="S^C^"_FH D ^FHORX ;file event
Q
;
ADDSO(FHDFN,FHADM,FHML,FHSO,FHN) ; Add Standing Order
N FHX,FH
S FH=0
AGN L +^FHPT(FHDFN,"A",FHADM,"SP",0)
I '$D(^FHPT(FHDFN,"A",FHADM,"SP",0)) S ^FHPT(FHDFN,"A",FHADM,"SP",0)="^115.08^^"
S FHX=^FHPT(FHDFN,"A",FHADM,"SP",0),FH=$P(FHX,"^",3)+1,^(0)=$P(FHX,"^",1,2)_"^"_FH_"^"_($P(FHX,"^",4)+1)
L -^FHPT(FHDFN,"A",FHADM,"SP",0)
G:$D(^FHPT(FHDFN,"A",FHADM,"SP",FH)) AGN
S ^FHPT(FHDFN,"A",FHADM,"SP",FH,0)=FH_"^"_FHSO_"^"_FHML_"^"_FHNOW_"^"_DUZ_"^^^"_FHN_"^Y",^FHPT("ASP",FHDFN,FHADM,FH)=""
Q FH
;
;--------- Suppl Feedings --------------------
SF ;check/update diet related SF,called from FHMTK7
D DOSF(FHDFN,ADM)
Q
DOSF(FHDFN,FHADM) ;check/update SF
;FHDFN-patient,FHADM-admission
N FHDSF,FH,FHPSF
;current DietPattr (DP)'s
S FH=$$CURDT(FHDFN,FHADM)
;update only for patterns edited
I FH'<0 Q:'$D(^TMP($J,+FH))
;DietPattr's SF menu (ien of 118.1)
S FHDSF=$P($G(^FH(111.1,FH,0)),"^",8)
;Patient's SF menu info
;CURRENT seq# of SF MENU entered via SF menu option
S FHPSF("N")=$P($G(^FHPT(FHDFN,"A",FHADM,0)),"^",7)
S FHPSF("E")=$S(FHPSF("N")="":1,1:0) ;1-if cancelled Explicitly
; if not cancelled Explicitly it still can be entered explicitly
; as well as via diet pattern
; pick up SF seq# from subfile
S:FHPSF("E")=1 FHPSF("N")=$P($G(^FHPT(FHDFN,"A",FHADM,"SF",0)),"^",3)
;get SF info
S FHPSF=$G(^FHPT(FHDFN,"A",FHADM,"SF",+FHPSF("N"),0))
;if it is expired or cancelled
S FHPSF("C")=$S($P(FHPSF,"^",32)="":0,1:1)
;if INDIVIDUALIZED - do nothing
Q:+$P(FHPSF,"^",4)=1
;if it is not diet related or if it entered Explicitly via SF menu
;and diet pattern has no SF menu - then do nothing
I $P(FHPSF,"^",34)'="Y" Q:FHDSF=""
I FHPSF("E")=1 Q:FHDSF=""
D UPDSF(FHDFN,FHADM,FHDSF,.FHPSF)
Q
;
UPDSF(FHDFN,FHADM,FHSF,FHPSF) ;updates diet related Suppl.Feed.
N FHX,FHNO,FHPNO,FHPNN,FHNOW
D NOW^%DTC S FHNOW=%
;D PATNAME^FHOMUTL I DFN="" Q ;for ^FHORX
;I '$D(DFN) N DFN S DFN=FHDFN ;for ^FHORX
I '$D(ADM) N ADM S ADM=FHADM
I '$D(DUZ) W !,"Unknown user" Q
;if SF is diet related & diet pattr doesn't have SF - cancel it
I FHSF="" S FHNO(0)=+FHPSF("N") D:FHNO(0)>0 CANCSF Q
;Diet.Pattr's SFmenu items
S FHPNO=$G(^FH(118.1,+FHSF,1)) Q:FHPNO=""
;if no patient SF menu - add
G:+FHPSF("N")=0!(FHPSF("C")=1) CONT
;if diffr SF menu - change it
G:+$P(FHPSF,"^",4)'=+FHSF CONT
;If SF menu and its content are the same - do nothing
Q:$P(FHPSF,"^",5,29)=FHPNO
;cancel current and add new
CONT S FHPNN="^"_FHNOW_"^"_DUZ_"^"_FHSF_"^"_FHPNO
;create new record
TRYSF L +^FHPT(FHDFN,"A",FHADM,"SF",0)
I '$D(^FHPT(FHDFN,"A",FHADM,"SF",0)) S ^FHPT(FHDFN,"A",FHADM,"SF",0)="^115.07^^"
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)
L -^FHPT(FHDFN,"A",FHADM,"SF",0) I $D(^FHPT(FHDFN,"A",FHADM,"SF",FHNO)) G TRYSF
;add new
S ^FHPT(FHDFN,"A",FHADM,"SF",FHNO,0)=FHNO_"^"_$P(FHPNN,"^",2,99)
;when new one is OK - cancel previous & file event
D CANCSF
;update # and put timestamp for new record
S $P(^FHPT(FHDFN,"A",FHADM,0),"^",7)=FHNO
S:FHNO $P(^FHPT(FHDFN,"A",FHADM,"SF",FHNO,0),"^",30,31)=FHNOW_"^"_DUZ
;set diet related for new record
S:FHNO $P(^FHPT(FHDFN,"A",FHADM,"SF",FHNO,0),"^",34)="Y"
;file event
S EVT="F^O^"_FHNO D ^FHORX
Q
;cancel previous & file event
CANCSF I FHNO(0)'=0&(FHPSF("C")=0) D
. S $P(^FHPT(FHDFN,"A",FHADM,"SF",FHNO(0),0),"^",32,33)=FHNOW_"^"_DUZ
. S $P(^FHPT(FHDFN,"A",FHADM,0),"^",7)=""
. S EVT="F^C^"_FHNO(0) D ^FHORX
Q
;
CURDT(FHDFN,FHADM) ;get current patient's diet pattern ien of 111.1
N FHDT,FHOR,FHZ
S FHDT=$P($G(^FHPT(FHDFN,"A",FHADM,0)),"^",2) Q:FHDT<1 -1
S FHZ=$G(^FHPT(FHDFN,"A",FHADM,"DI",FHDT,0)),FHOR=$P(FHZ,"^",2,6) I "^^^^"[FHOR Q -1
S FHDT=$O(^FH(111.1,"AB",FHOR,0)) Q:FHDT="" -1 ;doesn't exist
Q FHDT
;
NEWTMP ;save original state before editing
Q:$O(^TMP($J,DA,""))'="" ;repeated editing
M ^TMP($J,DA)=^FH(111.1,DA)
Q
;
CLEANTMP ;
N FHA1,FHB1,FHDA
S FHDA=""
F S FHDA=$O(^TMP($J,FHDA)) Q:+FHDA=0 D
. S FHA1="^TMP($J,FHDA,"""")",FHB1="^FH(111.1,FHDA,"""")"
. F Q:$$FETCH(.FHA1,$J,FHDA)'=$$FETCH(.FHB1,111.1,FHDA) I FHA1="" K ^TMP($J,FHDA) Q
Q
;
FETCH(FHX,FHSUB,FHDP) ;
S FHX=$Q(@FHX)
I $P($P(FHX,",",1),"(",2)'=FHSUB!($P(FHX,",",2)'=FHDP) S FHX="" Q ""
Q $P(FHX,",",2,99)_"="_@FHX
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHMTK8 6968 printed Apr 09, 2024@20:59:55 Page 2
FHMTK8 ; HIOFO/SS - DIET PATTERN RELATED UPDATES ;02/22/01 09:02
+1 ;;5.5;DIETETICS;;Jan 28, 2005
+2 ;
SO ;check and update Stand.Orders,called from FHMTK7
+1 NEW FH
SET FH=$$DOSO(FHDFN,ADM)
+2 QUIT
+3 ;
DOSO(FHDFN,FHADM) ;check/update SO
+1 ;
+2 NEW FHMX,FHCNT,FHPSO,FHS1,FH,FHDP
+3 ;current DietPattr
SET FHDP=$$CURDT(FHDFN,FHADM)
+4 ;1)for patterns edited - update
+5 ;2)if no pattern/deleted (FHDP=-1) -cancel all diet related
+6 IF FHDP'<0
if '$DATA(^TMP($JOB,+FHDP))
QUIT 0
+7 SET FHCNT=0
+8 FOR FH=0:0
SET FH=$ORDER(^FHPT("ASP",FHDFN,FHADM,FH))
if FH<1
QUIT
Begin DoDot:1
+9 SET FHS1=$GET(^FHPT(FHDFN,"A",FHADM,"SP",FH,0))
+10 IF $PIECE(FHS1,"^",9)="Y"
SET FHCNT=FHCNT+1
SET FHPSO("C",FH)=FHS1
End DoDot:1
+11 ;0-no changes,1-changes
QUIT $$CHKSO(FHDP,.FHPSO)
+12 ;
CHKSO(FHDT,FHCSO) ;compares SO of diet patterns(FHDT)
+1 ;and patient (FHCSO)
+2 NEW FHML,FH,FHSO,FHCNT2,FH1,FH2
+3 SET FHCNT2=0
+4 ;-thru diff meals
FOR FHML="B","N","E"
Begin DoDot:1
+5 ;----thru diet pattern SO
SET FH1=0
+6 FOR
SET FH1=$ORDER(^FH(111.1,FHDT,FHML_"S",FH1))
if +FH1=0
QUIT
Begin DoDot:2
+7 SET FHCNT2=FHCNT2+1
+8 ;dietpat
SET FHCSO("N",FHCNT2)=FHML_"^"_^FH(111.1,FHDT,FHML_"S",FH1,0)
+9 ;-----thru patient's diet related SOrders
SET FH2=0
+10 FOR
SET FH2=$ORDER(FHCSO("C",FH2))
if +FH2=0
QUIT
Begin DoDot:3
+11 ;diff meal
if $PIECE(FHCSO("C",FH2),"^",3)'=FHML
QUIT
+12 IF $PIECE(FHCSO("C",FH2),"^",2)=+$PIECE(FHCSO("N",FHCNT2),"^",2)
Begin DoDot:4
+13 IF $PIECE(FHCSO("C",FH2),"^",8)'=$PIECE(FHCSO("N",FHCNT2),"^",3)
SET FHCSO("U",FH2)=FHCSO("C",FH2)
SET $PIECE(FHCSO("U",FH2),"^",8)=$PIECE(FHCSO("N",FHCNT2),"^",3)
+14 KILL FHCSO("N",FHCNT2),FHCSO("C",FH2)
QUIT
End DoDot:4
SET FH2=0
End DoDot:3
if +FH2=0
QUIT
End DoDot:2
End DoDot:1
+15 ;FHCSO contains info for update
+16 ;subscripts mean: "N"-insert,"U"-change amount,"C"-cancel
+17 ; updated
IF $DATA(FHCSO)
DO UPDTSO(FHDFN,FHADM,.FHCSO)
QUIT 1
+18 ;no changes
QUIT 0
+19 ;
UPDTSO(FHDFN,FHADM,FHUCSO) ;update Standing orders.
+1 ;FHUCSO-array(see CHKSO for format)
+2 NEW FHNOW,FH,FHNEW
+3 ;D PATNAME^FHOMUTL I DFN="" Q ;for ^FHORX
+4 ;I '$D(DFN) N DFN S DFN=FHDFN ;for ^FHORX
+5 IF '$DATA(ADM)
NEW ADM
SET ADM=FHADM
+6 DO NOW^%DTC
SET FHNOW=%
+7 IF '$DATA(DUZ)
WRITE !,"Unknown user"
QUIT
+8 ; cancel
+9 SET FH=0
FOR
SET FH=$ORDER(FHUCSO("C",FH))
if +FH=0
QUIT
Begin DoDot:1
+10 DO CANCSO
End DoDot:1
+11 ; update
+12 SET FH=0
FOR
SET FH=$ORDER(FHUCSO("U",FH))
if +FH=0
QUIT
Begin DoDot:1
+13 DO CANCSO
+14 SET FHNEW=$$ADDSO(FHDFN,FHADM,$PIECE(FHUCSO("U",FH),"^",3),$PIECE(FHUCSO("U",FH),"^",2),$PIECE(FHUCSO("U",FH),"^",8))
SET EVT="S^O^"_FHNEW
DO ^FHORX
End DoDot:1
+15 ; add new
+16 SET FH=0
FOR
SET FH=$ORDER(FHUCSO("N",FH))
if +FH=0
QUIT
Begin DoDot:1
+17 SET FHNEW=$$ADDSO(FHDFN,FHADM,$PIECE(FHUCSO("N",FH),"^",1),$PIECE(FHUCSO("N",FH),"^",2),$PIECE(FHUCSO("N",FH),"^",3))
SET EVT="S^O^"_FHNEW
DO ^FHORX
End DoDot:1
+18 QUIT
+19 ;
CANCSO ;cancel SO
+1 SET $PIECE(^FHPT(FHDFN,"A",FHADM,"SP",FH,0),"^",6,7)=FHNOW_"^"_DUZ
+2 KILL ^FHPT("ASP",FHDFN,FHADM,FH)
+3 ;file event
SET EVT="S^C^"_FH
DO ^FHORX
+4 QUIT
+5 ;
ADDSO(FHDFN,FHADM,FHML,FHSO,FHN) ; Add Standing Order
+1 NEW FHX,FH
+2 SET FH=0
AGN LOCK +^FHPT(FHDFN,"A",FHADM,"SP",0)
+1 IF '$DATA(^FHPT(FHDFN,"A",FHADM,"SP",0))
SET ^FHPT(FHDFN,"A",FHADM,"SP",0)="^115.08^^"
+2 SET FHX=^FHPT(FHDFN,"A",FHADM,"SP",0)
SET FH=$PIECE(FHX,"^",3)+1
SET ^(0)=$PIECE(FHX,"^",1,2)_"^"_FH_"^"_($PIECE(FHX,"^",4)+1)
+3 LOCK -^FHPT(FHDFN,"A",FHADM,"SP",0)
+4 if $DATA(^FHPT(FHDFN,"A",FHADM,"SP",FH))
GOTO AGN
+5 SET ^FHPT(FHDFN,"A",FHADM,"SP",FH,0)=FH_"^"_FHSO_"^"_FHML_"^"_FHNOW_"^"_DUZ_"^^^"_FHN_"^Y"
SET ^FHPT("ASP",FHDFN,FHADM,FH)=""
+6 QUIT FH
+7 ;
+8 ;--------- Suppl Feedings --------------------
SF ;check/update diet related SF,called from FHMTK7
+1 DO DOSF(FHDFN,ADM)
+2 QUIT
DOSF(FHDFN,FHADM) ;check/update SF
+1 ;FHDFN-patient,FHADM-admission
+2 NEW FHDSF,FH,FHPSF
+3 ;current DietPattr (DP)'s
+4 SET FH=$$CURDT(FHDFN,FHADM)
+5 ;update only for patterns edited
+6 IF FH'<0
if '$DATA(^TMP($JOB,+FH))
QUIT
+7 ;DietPattr's SF menu (ien of 118.1)
+8 SET FHDSF=$PIECE($GET(^FH(111.1,FH,0)),"^",8)
+9 ;Patient's SF menu info
+10 ;CURRENT seq# of SF MENU entered via SF menu option
+11 SET FHPSF("N")=$PIECE($GET(^FHPT(FHDFN,"A",FHADM,0)),"^",7)
+12 ;1-if cancelled Explicitly
SET FHPSF("E")=$SELECT(FHPSF("N")="":1,1:0)
+13 ; if not cancelled Explicitly it still can be entered explicitly
+14 ; as well as via diet pattern
+15 ; pick up SF seq# from subfile
+16 if FHPSF("E")=1
SET FHPSF("N")=$PIECE($GET(^FHPT(FHDFN,"A",FHADM,"SF",0)),"^",3)
+17 ;get SF info
+18 SET FHPSF=$GET(^FHPT(FHDFN,"A",FHADM,"SF",+FHPSF("N"),0))
+19 ;if it is expired or cancelled
+20 SET FHPSF("C")=$SELECT($PIECE(FHPSF,"^",32)="":0,1:1)
+21 ;if INDIVIDUALIZED - do nothing
+22 if +$PIECE(FHPSF,"^",4)=1
QUIT
+23 ;if it is not diet related or if it entered Explicitly via SF menu
+24 ;and diet pattern has no SF menu - then do nothing
+25 IF $PIECE(FHPSF,"^",34)'="Y"
if FHDSF=""
QUIT
+26 IF FHPSF("E")=1
if FHDSF=""
QUIT
+27 DO UPDSF(FHDFN,FHADM,FHDSF,.FHPSF)
+28 QUIT
+29 ;
UPDSF(FHDFN,FHADM,FHSF,FHPSF) ;updates diet related Suppl.Feed.
+1 NEW FHX,FHNO,FHPNO,FHPNN,FHNOW
+2 DO NOW^%DTC
SET FHNOW=%
+3 ;D PATNAME^FHOMUTL I DFN="" Q ;for ^FHORX
+4 ;I '$D(DFN) N DFN S DFN=FHDFN ;for ^FHORX
+5 IF '$DATA(ADM)
NEW ADM
SET ADM=FHADM
+6 IF '$DATA(DUZ)
WRITE !,"Unknown user"
QUIT
+7 ;if SF is diet related & diet pattr doesn't have SF - cancel it
+8 IF FHSF=""
SET FHNO(0)=+FHPSF("N")
if FHNO(0)>0
DO CANCSF
QUIT
+9 ;Diet.Pattr's SFmenu items
+10 SET FHPNO=$GET(^FH(118.1,+FHSF,1))
if FHPNO=""
QUIT
+11 ;if no patient SF menu - add
+12 if +FHPSF("N")=0!(FHPSF("C")=1)
GOTO CONT
+13 ;if diffr SF menu - change it
+14 if +$PIECE(FHPSF,"^",4)'=+FHSF
GOTO CONT
+15 ;If SF menu and its content are the same - do nothing
+16 if $PIECE(FHPSF,"^",5,29)=FHPNO
QUIT
+17 ;cancel current and add new
CONT SET FHPNN="^"_FHNOW_"^"_DUZ_"^"_FHSF_"^"_FHPNO
+1 ;create new record
TRYSF LOCK +^FHPT(FHDFN,"A",FHADM,"SF",0)
+1 IF '$DATA(^FHPT(FHDFN,"A",FHADM,"SF",0))
SET ^FHPT(FHDFN,"A",FHADM,"SF",0)="^115.07^^"
+2 SET FHX=^FHPT(FHDFN,"A",FHADM,"SF",0)
SET FHNO(0)=+$PIECE(FHX,"^",3)
SET FHNO=FHNO(0)+1
SET ^(0)=$PIECE(FHX,"^",1,2)_"^"_FHNO_"^"_($PIECE(FHX,"^",4)+1)
+3 LOCK -^FHPT(FHDFN,"A",FHADM,"SF",0)
IF $DATA(^FHPT(FHDFN,"A",FHADM,"SF",FHNO))
GOTO TRYSF
+4 ;add new
+5 SET ^FHPT(FHDFN,"A",FHADM,"SF",FHNO,0)=FHNO_"^"_$PIECE(FHPNN,"^",2,99)
+6 ;when new one is OK - cancel previous & file event
+7 DO CANCSF
+8 ;update # and put timestamp for new record
+9 SET $PIECE(^FHPT(FHDFN,"A",FHADM,0),"^",7)=FHNO
+10 if FHNO
SET $PIECE(^FHPT(FHDFN,"A",FHADM,"SF",FHNO,0),"^",30,31)=FHNOW_"^"_DUZ
+11 ;set diet related for new record
+12 if FHNO
SET $PIECE(^FHPT(FHDFN,"A",FHADM,"SF",FHNO,0),"^",34)="Y"
+13 ;file event
+14 SET EVT="F^O^"_FHNO
DO ^FHORX
+15 QUIT
+16 ;cancel previous & file event
CANCSF IF FHNO(0)'=0&(FHPSF("C")=0)
Begin DoDot:1
+1 SET $PIECE(^FHPT(FHDFN,"A",FHADM,"SF",FHNO(0),0),"^",32,33)=FHNOW_"^"_DUZ
+2 SET $PIECE(^FHPT(FHDFN,"A",FHADM,0),"^",7)=""
+3 SET EVT="F^C^"_FHNO(0)
DO ^FHORX
End DoDot:1
+4 QUIT
+5 ;
CURDT(FHDFN,FHADM) ;get current patient's diet pattern ien of 111.1
+1 NEW FHDT,FHOR,FHZ
+2 SET FHDT=$PIECE($GET(^FHPT(FHDFN,"A",FHADM,0)),"^",2)
if FHDT<1
QUIT -1
+3 SET FHZ=$GET(^FHPT(FHDFN,"A",FHADM,"DI",FHDT,0))
SET FHOR=$PIECE(FHZ,"^",2,6)
IF "^^^^"[FHOR
QUIT -1
+4 ;doesn't exist
SET FHDT=$ORDER(^FH(111.1,"AB",FHOR,0))
if FHDT=""
QUIT -1
+5 QUIT FHDT
+6 ;
NEWTMP ;save original state before editing
+1 ;repeated editing
if $ORDER(^TMP($JOB,DA,""))'=""
QUIT
+2 MERGE ^TMP($JOB,DA)=^FH(111.1,DA)
+3 QUIT
+4 ;
CLEANTMP ;
+1 NEW FHA1,FHB1,FHDA
+2 SET FHDA=""
+3 FOR
SET FHDA=$ORDER(^TMP($JOB,FHDA))
if +FHDA=0
QUIT
Begin DoDot:1
+4 SET FHA1="^TMP($J,FHDA,"""")"
SET FHB1="^FH(111.1,FHDA,"""")"
+5 FOR
if $$FETCH(.FHA1,$JOB,FHDA)'=$$FETCH(.FHB1,111.1,FHDA)
QUIT
IF FHA1=""
KILL ^TMP($JOB,FHDA)
QUIT
End DoDot:1
+6 QUIT
+7 ;
FETCH(FHX,FHSUB,FHDP) ;
+1 SET FHX=$QUERY(@FHX)
+2 IF $PIECE($PIECE(FHX,",",1),"(",2)'=FHSUB!($PIECE(FHX,",",2)'=FHDP)
SET FHX=""
QUIT ""
+3 QUIT $PIECE(FHX,",",2,99)_"="_@FHX
+4 ;
