- 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
- 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
