FHMTK7 ; HISC/NCA - Update Diet Restrictions ;12/6/00 15:14
;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
; Update the Diet Restrictions For All Inpatients
; 11/14/05 -P5- added standing order & SF for outpatients.
R !!,"Update All Diet Related Information for Patients? Y // ",X:DTIME Q:'$T!(X["^")
S:X="" X="Y" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7,!," Answer YES or NO" G FHMTK7
S ANS=X?1"Y".E Q:'ANS
F W1=0:0 S W1=$O(^FHPT("AW",W1)) Q:W1'>0 F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN<1 S ADM=$G(^FHPT("AW",W1,FHDFN)) D:ADM PAT,STORD,SFMENU ;P30
D SOO ;update so for outpatient
D SFO ;update sf for outpt.
Q
STORD ;Update Standing orders for a patient, P30
D SO^FHMTK8
Q
D SF^FHMTK8
Q
PAT ; Update Restrictions for a patient
S FHORD=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",2) I FHORD<1 S DPAT="" G UPD
S Z=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)),FHOR=$P(Z,"^",2,6) I "^^^^"[FHOR S DPAT="" G UPD
S DPAT=$O(^FH(111.1,"AB",FHOR,0)) G:DPAT="" UPD
Q:'$D(^TMP($J,+DPAT))
;
UPD ; Update Pattern
S (COM,PP)=""
F SP=0:0 S SP=$O(^FHPT(FHDFN,"P",SP)) Q:SP<1 S M2=$G(^(SP,0)) I $P(M2,"^",4)="Y" D
.S FP=+M2 I $D(^FH(111.1,+DPAT,"RES","B",FP)) Q
.D PURG Q
F R1=0:0 S R1=$O(^FH(111.1,+DPAT,"RES",R1)) Q:R1<1 S M2=$G(^(R1,0)),FP=+M2 I FP D
.S SP=$O(^FHPT(FHDFN,"P","B",FP,0)) I 'SP D ADD Q
.I $P($G(^FHPT(FHDFN,"P",SP,0)),"^",2)=$P(M2,"^",2) Q
.D CHG Q
G FIL
CHG ; Change the Diet Restrictions
S MEAL=$P(M2,"^",2)
I $P($G(^FHPT(FHDFN,"P",SP,0)),"^",4)="Y" S M2=MEAL G CHG1 ;diet related
Q:MEAL=""
S M1=$P($G(^FHPT(FHDFN,"P",SP,0)),"^",2) Q:M1="" S:M1="A" M1="BNE"
S M2="" F LP=1:1:$L(MEAL) I M1'[$E(MEAL,LP) S M2=M2_$E(MEAL,LP)
Q:M2=""
S M1=M1_M2,M2="" S:M1["B" M2="B" S:M1["N" M2=M2_"N" S:M1["E" M2=M2_"E"
CHG1 S $P(^FHPT(FHDFN,"P",SP,0),"^",2)=M2
S PP=" Mod 1 "_$P(^FH(115.2,+FP,0),"^",1)_" ("_M2_")"_" (D)" D SET
Q
ADD ; Add the Diet Restriction
S MEAL=$P($G(M2),"^",2) Q:MEAL=""
K DIC,DD,DO S DIC="^FHPT(FHDFN,""P"",",DIC(0)="L",DLAYGO=115,DA(1)=FHDFN,X=+FP
A1 L +^FHPT(FHDFN,"P",0)
I '$D(^FHPT(FHDFN,"P",0)) S ^FHPT(FHDFN,"P",0)="^115.09PA^^"
S NUM=$P(^FHPT(FHDFN,"P",0),"^",3)+1
S $P(^FHPT(FHDFN,"P",0),"^",3)=NUM
L -^FHPT(FHDFN,"P",0) I $D(^FHPT(FHDFN,"P",NUM,0)) G A1
S DINUM=NUM D FILE^DICN S SP=+Y K DIC,DLAYGO,DINUM
S $P(^FHPT(FHDFN,"P",+SP,0),"^",2,4)=MEAL_"^^Y",PP=" Add 1 "_$P(^FH(115.2,+FP,0),"^",1)_" ("_$P(FP,"^",2)_")"_" (D)" D SET
Q
PURG ; Purge the Old Restrictions
S M1=$P($G(^FHPT(FHDFN,"P",SP,0)),"^",2) Q:M1="" S:M1="A" M1="BNE"
K DIK S DA(1)=FHDFN,DA=+SP,DIK="^FHPT("_DA(1)_",""P""," D ^DIK K DIK,DA S PP=" Del 1 "_$P(^FH(115.2,+FP,0),"^",1)_" ("_M1_")"_" (D)" D SET Q
SET I $L(COM)+$L(PP)>120 S EVT="P^O^^"_$E(COM,2,999) D ^FHORX S COM=""
S COM=COM_PP
Q
FIL ; File the Event
I COM'="" S EVT="P^O^^"_$E(COM,2,999) D ^FHORX
Q
;
SOO ;OUT SO
S FHCNT=0 K ^TMP("FH",$J)
F FHDFN=0:0 S FHDFN=$O(^FHPT("OP",FHDFN)) Q:FHDFN'>0 S FHSTADT="" F FHADAT=DT-1:0 S FHADAT=$O(^FHPT(FHDFN,"OP","B",FHADAT)) Q:FHADAT'>0 D
.I FHSTADT="" S DTP=FHADAT D DTP^FH S FHSTADT=DTP
.F FHADM=0:0 S FHADM=$O(^FHPT(FHDFN,"OP","B",FHADAT,FHADM)) Q:FHADM'>0 D
..S FHSOP=$G(^FHPT(FHDFN,"OP",FHADM,0))
..Q:$P(FHSOP,U,15)="C"
..K FHDT,FHCSO
..S FHDT=$$CURDT(FHDFN,FHADM)
..Q:'$G(FHDT)
..I FHDT'<0 Q:'$D(^TMP($J,+FHDT))
..D CHKSO
ADEV F FHDFN=0:0 S FHDFN=$O(^TMP("FH",$J,FHDFN)) Q:FHDFN'>0 F FHACT="C","O" F FHML="B","N","E" D
.S FHSO="" S FHSO=$O(^TMP("FH",$J,FHDFN,FHACT,FHML,FHSO)) Q:FHSO="" D
..S FHDATA=^TMP("FH",$J,FHDFN,FHACT,FHML,FHSO)
..S FHTXT=$P(FHDATA,U,1)_$P(FHDATA,U,2)
..I $P(FHDATA,U,2)'=$P(FHDATA,U,3) S FHTXT=FHTXT_" to "_$P(FHDATA,U,3)
..D OPFILE^FHORX
K ^TMP("FH",$J)
Q
;
CHKSO ;compares SO
K FHML,FH,FHSO,FH1,FH2
S FHML=$P(FHSOP,U,4)
F FH1=0:0 S FH1=$O(^FH(111.1,FHDT,FHML_"S",FH1)) Q:FH1'>0 D
.S FHDIPAT=^FH(111.1,FHDT,FHML_"S",FH1,0)
.S FHCSO("N",$P(FHDIPAT,U,1))=FHML_"^"_^FH(111.1,FHDT,FHML_"S",FH1,0)
;
F FHI=0:0 S FHI=$O(^FHPT(FHDFN,"OP",FHADM,"SP",FHI)) Q:FHI'>0 D
.S FHS1=$G(^FHPT(FHDFN,"OP",FHADM,"SP",FHI,0))
.Q:$P(FHS1,U,6)'=""
.I $P(FHS1,"^",9)="Y" S FHCNT=FHCNT+1,FHCSO("C",FHI)=FHS1
F FH2=0:0 S FH2=$O(FHCSO("C",FH2)) Q:FH2'>0 D
. Q:$P(FHCSO("C",FH2),"^",3)'=FHML ;diff meal
. S FHSOIEN=$P(FHCSO("C",FH2),U,2)
. I $D(FHCSO("N",FHSOIEN)) D
.. I $P(FHCSO("C",FH2),"^",8)'=$P(FHCSO("N",FHSOIEN),"^",3) D
... S FHCSO("U",FH2)=FHCSO("C",FH2),$P(FHCSO("U",FH2),"^",8)=$P(FHCSO("N",FHSOIEN),"^",3)
... K FHCSO("N",FHSOIEN),FHCSO("C",FH2) Q
I $D(FHCSO) D UPDTSO(FHDFN,FHADM,.FHCSO) Q
Q
;
UPDTSO(FHDFN,FHADM,FHUCSO) ;update SO
N FHNOW,FH,FHNEW
I '$D(ADM) N ADM S ADM=FHADM
D NOW^%DTC S FHNOW=%
I '$D(DUZ) W !,"Unknown user" Q
F FH=0:0 S FH=$O(FHUCSO("C",FH)) Q:FH'>0 D
. D CANCSO
F FH=0:0 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))
F FH=0:0 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))
Q
;
CANCSO ;cancel SO
S FHLOCN="",FHLOC=$P($G(^FHPT(FHDFN,"OP",FHADM,0)),U,3) I $G(FHLOC) S FHLOCN=$P($G(^FH(119.6,FHLOC,0)),U,1)
S $P(^FHPT(FHDFN,"OP",FHADM,"SP",FH,0),"^",6,7)=FHNOW_"^"_DUZ
S FHSODAT=$G(^FHPT(FHDFN,"OP",FHADM,"SP",FH,0)),FHSO=$P(FHSODAT,U,2),FHML=$P(FHSODAT,U,3),FHN=$P(FHSODAT,U,8)
K ^FHPT("ASPO",FHDFN,FHADM,FH)
S DTP=$P($G(^FHPT(FHDFN,"OP",FHADM,0)),U,1) D DTP^FH
S FHACT="C",FHTXT="Outpatient Standing Order: "_FHN_" "_$P($G(^FH(118.3,FHSO,0)),U,1)_" ("_FHML_") , "_FHLOCN_", Cancelled "
S ^TMP("FH",$J,FHDFN,"C",FHML,$P($G(^FH(118.3,FHSO,0)),U,1))=FHTXT_U_FHSTADT_U_DTP
Q
;
ADDSO(FHDFN,FHADM,FHML,FHSO,FHN) ;
N FHX,FH
S FHLOCN="",FHLOC=$P($G(^FHPT(FHDFN,"OP",FHADM,0)),U,3) I $G(FHLOC) S FHLOCN=$P($G(^FH(119.6,FHLOC,0)),U,1)
S FH=0
AGN L +^FHPT(FHDFN,"OP",FHADM,"SP",0)
I '$D(^FHPT(FHDFN,"OP",FHADM,"SP",0)) S ^FHPT(FHDFN,"OP",FHADM,"SP",0)="^115.1626^^"
S FHX=^FHPT(FHDFN,"OP",FHADM,"SP",0),FH=$P(FHX,"^",3)+1,^(0)=$P(FHX,"^",1,2)_"^"_FH_"^"_($P(FHX,"^",4)+1)
L -^FHPT(FHDFN,"OP",FHADM,"SP",0)
G:$D(^FHPT(FHDFN,"OP",FHADM,"SP",FH)) AGN
S ^FHPT(FHDFN,"OP",FHADM,"SP",FH,0)=FH_"^"_FHSO_"^"_FHML_"^"_FHNOW_"^"_DUZ_"^^^"_FHN_"^Y",^FHPT("ASPO",FHDFN,FHADM,FH)=""
S DTP=$P($G(^FHPT(FHDFN,"OP",FHADM,0)),U,1) D DTP^FH
S FHACT="O",FHTXT="Outpatient Standing Order: "_FHN_" "_$P($G(^FH(118.3,FHSO,0)),U,1)_" ("_FHML_") , "_FHLOCN_", "
S ^TMP("FH",$J,FHDFN,"O",FHML,$P($G(^FH(118.3,FHSO,0)),U,1))=FHTXT_U_FHSTADT_U_DTP
Q FH
;
SFO ;out SFs
S FHCNT=0 K ^TMP("FH",$J)
F FHDFN=0:0 S FHDFN=$O(^FHPT("OP",FHDFN)) Q:FHDFN'>0 S FHSTADT="" F FHADAT=DT-1:0 S FHADAT=$O(^FHPT(FHDFN,"OP","B",FHADAT)) Q:FHADAT'>0 D
.I FHSTADT="" S DTP=FHADAT D DTP^FH S FHSTADT=DTP
.F FHADM=0:0 S FHADM=$O(^FHPT(FHDFN,"OP","B",FHADAT,FHADM)) Q:FHADM'>0 D
..S FHSOP=$G(^FHPT(FHDFN,"OP",FHADM,0))
..Q:$P(FHSOP,U,15)="C"
..K FHDT,FHCSO
..S FHDT=$$CURDT(FHDFN,FHADM)
..Q:'$G(FHDT)
..I FHDT'<0 Q:'$D(^TMP($J,+FHDT))
..D DOSF(FHDFN,FHADM)
D ADEV
Q
DOSF(FHDFN,FHADM) ;check/update SF
N FHDSF,FH,FHPSF
S FH=$$CURDT(FHDFN,FHADM)
I FH'<0 Q:'$D(^TMP($J,+FH))
S FHDSF=$P($G(^FH(111.1,FH,0)),"^",8)
S FHPSF("N")=$P($G(^FHPT(FHDFN,"OP",FHADM,"SF",0)),U,3)
S FHPSF("E")=$S(FHPSF("N")="":1,1:0)
S:FHPSF("E")=1 FHPSF("N")=$P($G(^FHPT(FHDFN,"OP",FHADM,"SF",0)),"^",3)
S FHPSF=$G(^FHPT(FHDFN,"OP",FHADM,"SF",+FHPSF("N"),0))
S FHPSF("C")=$S($P(FHPSF,"^",32)="":0,1:1)
Q:+$P(FHPSF,"^",4)=1
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) ;
N FHX,FHNO,FHPNO,FHPNN,FHNOW,FHN3
D NOW^%DTC S FHNOW=%
S DTP=$P($G(^FHPT(FHDFN,"OP",FHADM,0)),U,1) D DTP^FH
I '$D(ADM) N ADM S ADM=FHADM
I '$D(DUZ) W !,"Unknown user" Q
S FHSFDAT=$G(^FHPT(FHDFN,"OP",FHADM,0))
S FHML=$P(FHSFDAT,U,4),FHLOCN=""
S FHLOC=$P(FHSFDAT,U,3) S:FHLOC FHLOCN=$P($G(^FH(119.6,FHLOC,0)),U,1)
I FHSF="" S FHN3=+FHPSF("N") D:FHN3>0 CANCSF Q
S FHPNO=$G(^FH(118.1,+FHSF,1)) Q:FHPNO=""
G:+FHPSF("N")=0!(FHPSF("C")=1) CONT
G:+$P(FHPSF,"^",4)'=+FHSF CONT
Q:$P(FHPSF,"^",5,29)=FHPNO
CONT S FHPNN="^"_FHNOW_"^"_DUZ_"^"_FHSF_"^"_FHPNO
;
TRYSF L +^FHPT(FHDFN,"OP",FHADM,"SF",0)
I '$D(^FHPT(FHDFN,"OP",FHADM,"SF",0)) S ^FHPT(FHDFN,"OP",FHADM,"SF",0)="^115.1627^^"
S FHX=^FHPT(FHDFN,"OP",FHADM,"SF",0),FHN3=+$P(FHX,"^",3),FHNO=FHN3+1,^(0)=$P(FHX,"^",1,2)_"^"_FHNO_"^"_($P(FHX,"^",4)+1)
L -^FHPT(FHDFN,"OP",FHADM,"SF",0) I $D(^FHPT(FHDFN,"OP",FHADM,"SF",FHNO)) G TRYSF
S ^FHPT(FHDFN,"OP",FHADM,"SF",FHNO,0)=FHNO_"^"_$P(FHPNN,"^",2,99)
I FHN3,$D(^FHPT(FHDFN,"OP",FHADM,"SF",FHN3,0)),'$P(^(0),U,32) D CANCSF
S:FHNO $P(^FHPT(FHDFN,"OP",FHADM,"SF",FHNO,0),"^",30,31)=FHNOW_"^"_DUZ
S:FHNO $P(^FHPT(FHDFN,"OP",FHADM,"SF",FHNO,0),"^",34)="Y"
S FHACT="O",FHTXT="Outpatient Supplemental Feeding: "_$P($G(^FH(118.1,+FHSF,0)),U,1)_" ("_FHML_") , "_FHLOCN_", "
S ^TMP("FH",$J,FHDFN,"O",FHML,$P($G(^FH(118.1,FHSF,0)),U,1))=FHTXT_U_FHSTADT_U_DTP
Q
CANCSF I FHN3'=0&(FHPSF("C")=0) D
. S $P(^FHPT(FHDFN,"OP",FHADM,"SF",FHN3,0),"^",32,33)=FHNOW_"^"_DUZ
. S $P(^FHPT(FHDFN,"OP",FHADM,0),"^",7)=""
. S FHACT="C",FHTXT="Outpatient Supplemental Feeding: "_$P($G(^FH(118.1,+FHN3,0)),U,1)_" ("_FHML_") , "_FHLOCN_", Cancelled "
. S ^TMP("FH",$J,FHDFN,"C",FHML,$P($G(^FH(118.1,FHN3,0)),U,1))=FHTXT_U_FHSTADT_U_DTP
Q
;
CURDT(FHDFN,FHADM) ;get current patient's diet pattern ien of 111.1
N FHDT,FHOR
S FHOR="",FHDT=$P($G(^FHPT(FHDFN,"OP",FHADM,0)),"^",2)
I FHDT="" S FHOR=$P($G(^FHPT(FHDFN,"OP",FHADM,0)),U,7,11)
I FHOR'["^" S FHOR=FHDT_"^^^^"
S FHDT=$O(^FH(111.1,"AB",FHOR,0)) Q:FHDT="" -1 ;doesn't exist
Q FHDT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHMTK7 9863 printed Sep 23, 2025@19:24:15 Page 2
FHMTK7 ; HISC/NCA - Update Diet Restrictions ;12/6/00 15:14
+1 ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
+2 ; Update the Diet Restrictions For All Inpatients
+3 ; 11/14/05 -P5- added standing order & SF for outpatients.
+4 READ !!,"Update All Diet Related Information for Patients? Y // ",X:DTIME
if '$TEST!(X["^")
QUIT
+5 if X=""
SET X="Y"
DO TR^FH
IF $PIECE("YES",X,1)'=""
IF $PIECE("NO",X,1)'=""
WRITE *7,!," Answer YES or NO"
GOTO FHMTK7
+6 SET ANS=X?1"Y".E
if 'ANS
QUIT
+7 ;P30
FOR W1=0:0
SET W1=$ORDER(^FHPT("AW",W1))
if W1'>0
QUIT
FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("AW",W1,FHDFN))
if FHDFN<1
QUIT
SET ADM=$GET(^FHPT("AW",W1,FHDFN))
if ADM
DO PAT
DO STORD
DO SFMENU
+8 ;update so for outpatient
DO SOO
+9 ;update sf for outpt.
DO SFO
+10 QUIT
STORD ;Update Standing orders for a patient, P30
+1 DO SO^FHMTK8
+2 QUIT
+1 DO SF^FHMTK8
+2 QUIT
PAT ; Update Restrictions for a patient
+1 SET FHORD=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",2)
IF FHORD<1
SET DPAT=""
GOTO UPD
+2 SET Z=$GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
SET FHOR=$PIECE(Z,"^",2,6)
IF "^^^^"[FHOR
SET DPAT=""
GOTO UPD
+3 SET DPAT=$ORDER(^FH(111.1,"AB",FHOR,0))
if DPAT=""
GOTO UPD
+4 if '$DATA(^TMP($JOB,+DPAT))
QUIT
+5 ;
UPD ; Update Pattern
+1 SET (COM,PP)=""
+2 FOR SP=0:0
SET SP=$ORDER(^FHPT(FHDFN,"P",SP))
if SP<1
QUIT
SET M2=$GET(^(SP,0))
IF $PIECE(M2,"^",4)="Y"
Begin DoDot:1
+3 SET FP=+M2
IF $DATA(^FH(111.1,+DPAT,"RES","B",FP))
QUIT
+4 DO PURG
QUIT
End DoDot:1
+5 FOR R1=0:0
SET R1=$ORDER(^FH(111.1,+DPAT,"RES",R1))
if R1<1
QUIT
SET M2=$GET(^(R1,0))
SET FP=+M2
IF FP
Begin DoDot:1
+6 SET SP=$ORDER(^FHPT(FHDFN,"P","B",FP,0))
IF 'SP
DO ADD
QUIT
+7 IF $PIECE($GET(^FHPT(FHDFN,"P",SP,0)),"^",2)=$PIECE(M2,"^",2)
QUIT
+8 DO CHG
QUIT
End DoDot:1
+9 GOTO FIL
CHG ; Change the Diet Restrictions
+1 SET MEAL=$PIECE(M2,"^",2)
+2 ;diet related
IF $PIECE($GET(^FHPT(FHDFN,"P",SP,0)),"^",4)="Y"
SET M2=MEAL
GOTO CHG1
+3 if MEAL=""
QUIT
+4 SET M1=$PIECE($GET(^FHPT(FHDFN,"P",SP,0)),"^",2)
if M1=""
QUIT
if M1="A"
SET M1="BNE"
+5 SET M2=""
FOR LP=1:1:$LENGTH(MEAL)
IF M1'[$EXTRACT(MEAL,LP)
SET M2=M2_$EXTRACT(MEAL,LP)
+6 if M2=""
QUIT
+7 SET M1=M1_M2
SET M2=""
if M1["B"
SET M2="B"
if M1["N"
SET M2=M2_"N"
if M1["E"
SET M2=M2_"E"
CHG1 SET $PIECE(^FHPT(FHDFN,"P",SP,0),"^",2)=M2
+1 SET PP=" Mod 1 "_$PIECE(^FH(115.2,+FP,0),"^",1)_" ("_M2_")"_" (D)"
DO SET
+2 QUIT
ADD ; Add the Diet Restriction
+1 SET MEAL=$PIECE($GET(M2),"^",2)
if MEAL=""
QUIT
+2 KILL DIC,DD,DO
SET DIC="^FHPT(FHDFN,""P"","
SET DIC(0)="L"
SET DLAYGO=115
SET DA(1)=FHDFN
SET X=+FP
A1 LOCK +^FHPT(FHDFN,"P",0)
+1 IF '$DATA(^FHPT(FHDFN,"P",0))
SET ^FHPT(FHDFN,"P",0)="^115.09PA^^"
+2 SET NUM=$PIECE(^FHPT(FHDFN,"P",0),"^",3)+1
+3 SET $PIECE(^FHPT(FHDFN,"P",0),"^",3)=NUM
+4 LOCK -^FHPT(FHDFN,"P",0)
IF $DATA(^FHPT(FHDFN,"P",NUM,0))
GOTO A1
+5 SET DINUM=NUM
DO FILE^DICN
SET SP=+Y
KILL DIC,DLAYGO,DINUM
+6 SET $PIECE(^FHPT(FHDFN,"P",+SP,0),"^",2,4)=MEAL_"^^Y"
SET PP=" Add 1 "_$PIECE(^FH(115.2,+FP,0),"^",1)_" ("_$PIECE(FP,"^",2)_")"_" (D)"
DO SET
+7 QUIT
PURG ; Purge the Old Restrictions
+1 SET M1=$PIECE($GET(^FHPT(FHDFN,"P",SP,0)),"^",2)
if M1=""
QUIT
if M1="A"
SET M1="BNE"
+2 KILL DIK
SET DA(1)=FHDFN
SET DA=+SP
SET DIK="^FHPT("_DA(1)_",""P"","
DO ^DIK
KILL DIK,DA
SET PP=" Del 1 "_$PIECE(^FH(115.2,+FP,0),"^",1)_" ("_M1_")"_" (D)"
DO SET
QUIT
SET IF $LENGTH(COM)+$LENGTH(PP)>120
SET EVT="P^O^^"_$EXTRACT(COM,2,999)
DO ^FHORX
SET COM=""
+1 SET COM=COM_PP
+2 QUIT
FIL ; File the Event
+1 IF COM'=""
SET EVT="P^O^^"_$EXTRACT(COM,2,999)
DO ^FHORX
+2 QUIT
+3 ;
SOO ;OUT SO
+1 SET FHCNT=0
KILL ^TMP("FH",$JOB)
+2 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("OP",FHDFN))
if FHDFN'>0
QUIT
SET FHSTADT=""
FOR FHADAT=DT-1:0
SET FHADAT=$ORDER(^FHPT(FHDFN,"OP","B",FHADAT))
if FHADAT'>0
QUIT
Begin DoDot:1
+3 IF FHSTADT=""
SET DTP=FHADAT
DO DTP^FH
SET FHSTADT=DTP
+4 FOR FHADM=0:0
SET FHADM=$ORDER(^FHPT(FHDFN,"OP","B",FHADAT,FHADM))
if FHADM'>0
QUIT
Begin DoDot:2
+5 SET FHSOP=$GET(^FHPT(FHDFN,"OP",FHADM,0))
+6 if $PIECE(FHSOP,U,15)="C"
QUIT
+7 KILL FHDT,FHCSO
+8 SET FHDT=$$CURDT(FHDFN,FHADM)
+9 if '$GET(FHDT)
QUIT
+10 IF FHDT'<0
if '$DATA(^TMP($JOB,+FHDT))
QUIT
+11 DO CHKSO
End DoDot:2
End DoDot:1
ADEV FOR FHDFN=0:0
SET FHDFN=$ORDER(^TMP("FH",$JOB,FHDFN))
if FHDFN'>0
QUIT
FOR FHACT="C","O"
FOR FHML="B","N","E"
Begin DoDot:1
+1 SET FHSO=""
SET FHSO=$ORDER(^TMP("FH",$JOB,FHDFN,FHACT,FHML,FHSO))
if FHSO=""
QUIT
Begin DoDot:2
+2 SET FHDATA=^TMP("FH",$JOB,FHDFN,FHACT,FHML,FHSO)
+3 SET FHTXT=$PIECE(FHDATA,U,1)_$PIECE(FHDATA,U,2)
+4 IF $PIECE(FHDATA,U,2)'=$PIECE(FHDATA,U,3)
SET FHTXT=FHTXT_" to "_$PIECE(FHDATA,U,3)
+5 DO OPFILE^FHORX
End DoDot:2
End DoDot:1
+6 KILL ^TMP("FH",$JOB)
+7 QUIT
+8 ;
CHKSO ;compares SO
+1 KILL FHML,FH,FHSO,FH1,FH2
+2 SET FHML=$PIECE(FHSOP,U,4)
+3 FOR FH1=0:0
SET FH1=$ORDER(^FH(111.1,FHDT,FHML_"S",FH1))
if FH1'>0
QUIT
Begin DoDot:1
+4 SET FHDIPAT=^FH(111.1,FHDT,FHML_"S",FH1,0)
+5 SET FHCSO("N",$PIECE(FHDIPAT,U,1))=FHML_"^"_^FH(111.1,FHDT,FHML_"S",FH1,0)
End DoDot:1
+6 ;
+7 FOR FHI=0:0
SET FHI=$ORDER(^FHPT(FHDFN,"OP",FHADM,"SP",FHI))
if FHI'>0
QUIT
Begin DoDot:1
+8 SET FHS1=$GET(^FHPT(FHDFN,"OP",FHADM,"SP",FHI,0))
+9 if $PIECE(FHS1,U,6)'=""
QUIT
+10 IF $PIECE(FHS1,"^",9)="Y"
SET FHCNT=FHCNT+1
SET FHCSO("C",FHI)=FHS1
End DoDot:1
+11 FOR FH2=0:0
SET FH2=$ORDER(FHCSO("C",FH2))
if FH2'>0
QUIT
Begin DoDot:1
+12 ;diff meal
if $PIECE(FHCSO("C",FH2),"^",3)'=FHML
QUIT
+13 SET FHSOIEN=$PIECE(FHCSO("C",FH2),U,2)
+14 IF $DATA(FHCSO("N",FHSOIEN))
Begin DoDot:2
+15 IF $PIECE(FHCSO("C",FH2),"^",8)'=$PIECE(FHCSO("N",FHSOIEN),"^",3)
Begin DoDot:3
+16 SET FHCSO("U",FH2)=FHCSO("C",FH2)
SET $PIECE(FHCSO("U",FH2),"^",8)=$PIECE(FHCSO("N",FHSOIEN),"^",3)
+17 KILL FHCSO("N",FHSOIEN),FHCSO("C",FH2)
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+18 IF $DATA(FHCSO)
DO UPDTSO(FHDFN,FHADM,.FHCSO)
QUIT
+19 QUIT
+20 ;
UPDTSO(FHDFN,FHADM,FHUCSO) ;update SO
+1 NEW FHNOW,FH,FHNEW
+2 IF '$DATA(ADM)
NEW ADM
SET ADM=FHADM
+3 DO NOW^%DTC
SET FHNOW=%
+4 IF '$DATA(DUZ)
WRITE !,"Unknown user"
QUIT
+5 FOR FH=0:0
SET FH=$ORDER(FHUCSO("C",FH))
if FH'>0
QUIT
Begin DoDot:1
+6 DO CANCSO
End DoDot:1
+7 FOR FH=0:0
SET FH=$ORDER(FHUCSO("U",FH))
if FH'>0
QUIT
Begin DoDot:1
+8 DO CANCSO
+9 SET FHNEW=$$ADDSO(FHDFN,FHADM,$PIECE(FHUCSO("U",FH),"^",3),$PIECE(FHUCSO("U",FH),"^",2),$PIECE(FHUCSO("U",FH),"^",8))
End DoDot:1
+10 FOR FH=0:0
SET FH=$ORDER(FHUCSO("N",FH))
if FH'>0
QUIT
Begin DoDot:1
+11 SET FHNEW=$$ADDSO(FHDFN,FHADM,$PIECE(FHUCSO("N",FH),"^",1),$PIECE(FHUCSO("N",FH),"^",2),$PIECE(FHUCSO("N",FH),"^",3))
End DoDot:1
+12 QUIT
+13 ;
CANCSO ;cancel SO
+1 SET FHLOCN=""
SET FHLOC=$PIECE($GET(^FHPT(FHDFN,"OP",FHADM,0)),U,3)
IF $GET(FHLOC)
SET FHLOCN=$PIECE($GET(^FH(119.6,FHLOC,0)),U,1)
+2 SET $PIECE(^FHPT(FHDFN,"OP",FHADM,"SP",FH,0),"^",6,7)=FHNOW_"^"_DUZ
+3 SET FHSODAT=$GET(^FHPT(FHDFN,"OP",FHADM,"SP",FH,0))
SET FHSO=$PIECE(FHSODAT,U,2)
SET FHML=$PIECE(FHSODAT,U,3)
SET FHN=$PIECE(FHSODAT,U,8)
+4 KILL ^FHPT("ASPO",FHDFN,FHADM,FH)
+5 SET DTP=$PIECE($GET(^FHPT(FHDFN,"OP",FHADM,0)),U,1)
DO DTP^FH
+6 SET FHACT="C"
SET FHTXT="Outpatient Standing Order: "_FHN_" "_$PIECE($GET(^FH(118.3,FHSO,0)),U,1)_" ("_FHML_") , "_FHLOCN_", Cancelled "
+7 SET ^TMP("FH",$JOB,FHDFN,"C",FHML,$PIECE($GET(^FH(118.3,FHSO,0)),U,1))=FHTXT_U_FHSTADT_U_DTP
+8 QUIT
+9 ;
ADDSO(FHDFN,FHADM,FHML,FHSO,FHN) ;
+1 NEW FHX,FH
+2 SET FHLOCN=""
SET FHLOC=$PIECE($GET(^FHPT(FHDFN,"OP",FHADM,0)),U,3)
IF $GET(FHLOC)
SET FHLOCN=$PIECE($GET(^FH(119.6,FHLOC,0)),U,1)
+3 SET FH=0
AGN LOCK +^FHPT(FHDFN,"OP",FHADM,"SP",0)
+1 IF '$DATA(^FHPT(FHDFN,"OP",FHADM,"SP",0))
SET ^FHPT(FHDFN,"OP",FHADM,"SP",0)="^115.1626^^"
+2 SET FHX=^FHPT(FHDFN,"OP",FHADM,"SP",0)
SET FH=$PIECE(FHX,"^",3)+1
SET ^(0)=$PIECE(FHX,"^",1,2)_"^"_FH_"^"_($PIECE(FHX,"^",4)+1)
+3 LOCK -^FHPT(FHDFN,"OP",FHADM,"SP",0)
+4 if $DATA(^FHPT(FHDFN,"OP",FHADM,"SP",FH))
GOTO AGN
+5 SET ^FHPT(FHDFN,"OP",FHADM,"SP",FH,0)=FH_"^"_FHSO_"^"_FHML_"^"_FHNOW_"^"_DUZ_"^^^"_FHN_"^Y"
SET ^FHPT("ASPO",FHDFN,FHADM,FH)=""
+6 SET DTP=$PIECE($GET(^FHPT(FHDFN,"OP",FHADM,0)),U,1)
DO DTP^FH
+7 SET FHACT="O"
SET FHTXT="Outpatient Standing Order: "_FHN_" "_$PIECE($GET(^FH(118.3,FHSO,0)),U,1)_" ("_FHML_") , "_FHLOCN_", "
+8 SET ^TMP("FH",$JOB,FHDFN,"O",FHML,$PIECE($GET(^FH(118.3,FHSO,0)),U,1))=FHTXT_U_FHSTADT_U_DTP
+9 QUIT FH
+10 ;
SFO ;out SFs
+1 SET FHCNT=0
KILL ^TMP("FH",$JOB)
+2 FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("OP",FHDFN))
if FHDFN'>0
QUIT
SET FHSTADT=""
FOR FHADAT=DT-1:0
SET FHADAT=$ORDER(^FHPT(FHDFN,"OP","B",FHADAT))
if FHADAT'>0
QUIT
Begin DoDot:1
+3 IF FHSTADT=""
SET DTP=FHADAT
DO DTP^FH
SET FHSTADT=DTP
+4 FOR FHADM=0:0
SET FHADM=$ORDER(^FHPT(FHDFN,"OP","B",FHADAT,FHADM))
if FHADM'>0
QUIT
Begin DoDot:2
+5 SET FHSOP=$GET(^FHPT(FHDFN,"OP",FHADM,0))
+6 if $PIECE(FHSOP,U,15)="C"
QUIT
+7 KILL FHDT,FHCSO
+8 SET FHDT=$$CURDT(FHDFN,FHADM)
+9 if '$GET(FHDT)
QUIT
+10 IF FHDT'<0
if '$DATA(^TMP($JOB,+FHDT))
QUIT
+11 DO DOSF(FHDFN,FHADM)
End DoDot:2
End DoDot:1
+12 DO ADEV
+13 QUIT
DOSF(FHDFN,FHADM) ;check/update SF
+1 NEW FHDSF,FH,FHPSF
+2 SET FH=$$CURDT(FHDFN,FHADM)
+3 IF FH'<0
if '$DATA(^TMP($JOB,+FH))
QUIT
+4 SET FHDSF=$PIECE($GET(^FH(111.1,FH,0)),"^",8)
+5 SET FHPSF("N")=$PIECE($GET(^FHPT(FHDFN,"OP",FHADM,"SF",0)),U,3)
+6 SET FHPSF("E")=$SELECT(FHPSF("N")="":1,1:0)
+7 if FHPSF("E")=1
SET FHPSF("N")=$PIECE($GET(^FHPT(FHDFN,"OP",FHADM,"SF",0)),"^",3)
+8 SET FHPSF=$GET(^FHPT(FHDFN,"OP",FHADM,"SF",+FHPSF("N"),0))
+9 SET FHPSF("C")=$SELECT($PIECE(FHPSF,"^",32)="":0,1:1)
+10 if +$PIECE(FHPSF,"^",4)=1
QUIT
+11 IF $PIECE(FHPSF,"^",34)'="Y"
if FHDSF=""
QUIT
+12 IF FHPSF("E")=1
if FHDSF=""
QUIT
+13 DO UPDSF(FHDFN,FHADM,FHDSF,.FHPSF)
+14 QUIT
+15 ;
UPDSF(FHDFN,FHADM,FHSF,FHPSF) ;
+1 NEW FHX,FHNO,FHPNO,FHPNN,FHNOW,FHN3
+2 DO NOW^%DTC
SET FHNOW=%
+3 SET DTP=$PIECE($GET(^FHPT(FHDFN,"OP",FHADM,0)),U,1)
DO DTP^FH
+4 IF '$DATA(ADM)
NEW ADM
SET ADM=FHADM
+5 IF '$DATA(DUZ)
WRITE !,"Unknown user"
QUIT
+6 SET FHSFDAT=$GET(^FHPT(FHDFN,"OP",FHADM,0))
+7 SET FHML=$PIECE(FHSFDAT,U,4)
SET FHLOCN=""
+8 SET FHLOC=$PIECE(FHSFDAT,U,3)
if FHLOC
SET FHLOCN=$PIECE($GET(^FH(119.6,FHLOC,0)),U,1)
+9 IF FHSF=""
SET FHN3=+FHPSF("N")
if FHN3>0
DO CANCSF
QUIT
+10 SET FHPNO=$GET(^FH(118.1,+FHSF,1))
if FHPNO=""
QUIT
+11 if +FHPSF("N")=0!(FHPSF("C")=1)
GOTO CONT
+12 if +$PIECE(FHPSF,"^",4)'=+FHSF
GOTO CONT
+13 if $PIECE(FHPSF,"^",5,29)=FHPNO
QUIT
CONT SET FHPNN="^"_FHNOW_"^"_DUZ_"^"_FHSF_"^"_FHPNO
+1 ;
TRYSF LOCK +^FHPT(FHDFN,"OP",FHADM,"SF",0)
+1 IF '$DATA(^FHPT(FHDFN,"OP",FHADM,"SF",0))
SET ^FHPT(FHDFN,"OP",FHADM,"SF",0)="^115.1627^^"
+2 SET FHX=^FHPT(FHDFN,"OP",FHADM,"SF",0)
SET FHN3=+$PIECE(FHX,"^",3)
SET FHNO=FHN3+1
SET ^(0)=$PIECE(FHX,"^",1,2)_"^"_FHNO_"^"_($PIECE(FHX,"^",4)+1)
+3 LOCK -^FHPT(FHDFN,"OP",FHADM,"SF",0)
IF $DATA(^FHPT(FHDFN,"OP",FHADM,"SF",FHNO))
GOTO TRYSF
+4 SET ^FHPT(FHDFN,"OP",FHADM,"SF",FHNO,0)=FHNO_"^"_$PIECE(FHPNN,"^",2,99)
+5 IF FHN3
IF $DATA(^FHPT(FHDFN,"OP",FHADM,"SF",FHN3,0))
IF '$PIECE(^(0),U,32)
DO CANCSF
+6 if FHNO
SET $PIECE(^FHPT(FHDFN,"OP",FHADM,"SF",FHNO,0),"^",30,31)=FHNOW_"^"_DUZ
+7 if FHNO
SET $PIECE(^FHPT(FHDFN,"OP",FHADM,"SF",FHNO,0),"^",34)="Y"
+8 SET FHACT="O"
SET FHTXT="Outpatient Supplemental Feeding: "_$PIECE($GET(^FH(118.1,+FHSF,0)),U,1)_" ("_FHML_") , "_FHLOCN_", "
+9 SET ^TMP("FH",$JOB,FHDFN,"O",FHML,$PIECE($GET(^FH(118.1,FHSF,0)),U,1))=FHTXT_U_FHSTADT_U_DTP
+10 QUIT
CANCSF IF FHN3'=0&(FHPSF("C")=0)
Begin DoDot:1
+1 SET $PIECE(^FHPT(FHDFN,"OP",FHADM,"SF",FHN3,0),"^",32,33)=FHNOW_"^"_DUZ
+2 SET $PIECE(^FHPT(FHDFN,"OP",FHADM,0),"^",7)=""
+3 SET FHACT="C"
SET FHTXT="Outpatient Supplemental Feeding: "_$PIECE($GET(^FH(118.1,+FHN3,0)),U,1)_" ("_FHML_") , "_FHLOCN_", Cancelled "
+4 SET ^TMP("FH",$JOB,FHDFN,"C",FHML,$PIECE($GET(^FH(118.1,FHN3,0)),U,1))=FHTXT_U_FHSTADT_U_DTP
End DoDot:1
+5 QUIT
+6 ;
CURDT(FHDFN,FHADM) ;get current patient's diet pattern ien of 111.1
+1 NEW FHDT,FHOR
+2 SET FHOR=""
SET FHDT=$PIECE($GET(^FHPT(FHDFN,"OP",FHADM,0)),"^",2)
+3 IF FHDT=""
SET FHOR=$PIECE($GET(^FHPT(FHDFN,"OP",FHADM,0)),U,7,11)
+4 IF FHOR'["^"
SET FHOR=FHDT_"^^^^"
+5 ;doesn't exist
SET FHDT=$ORDER(^FH(111.1,"AB",FHOR,0))
if FHDT=""
QUIT -1
+6 QUIT FHDT
