- FHCTF3 ; HISC/REL/NCA - Clear File Entries ;4/6/01 09:37
- ;;5.5;DIETETICS;**4**;Jan 28, 2005;Build 32
- E0 K DIC,^TMP($J) S DIC="^VA(200,",DIC(0)="AQEM",DIC("A")="Select CLINICIAN: ",DIC("B")=$P($G(^VA(200,DUZ,0)),"^",1) W ! D ^DIC K DIC G KIL:"^"[X!$D(DTOUT),E0:Y<1 S FHDUZ=+Y
- S (FHQT,CNT,QT)=0 D NOW^%DTC S NOW=%,DT=NOW\1 D CLN^FHCTF4 S $P(LN,"-",80)="",QT=""
- E1 F LLL=0:0 S LLL=$O(^FH(119,FHDUZ,"I",LLL)) Q:LLL<1 S FHTF=^(LLL,0),DFN=$P(FHTF,U,4),FHZ115="P"_DFN D CHECK^FHOMDPA I $G(FHDFN) D
- .D PATNAME^FHOMUTL
- .S ^TMP($J,FHPTNM,FHDFN,LLL)=FHDFN
- S FHPTNM=""
- CL0 S FHPTNM=$O(^TMP($J,FHPTNM)) G:(FHPTNM="")!(FHQT=U) OUT G CL1
- ;
- OUT G:FHQT=U KIL I 'CNT W !!,"No Tickler File Entries"
- W ! G KIL
- ;
- CL1 F FHDFN=0:0 S FHDFN=$O(^TMP($J,FHPTNM,FHDFN)) Q:FHDFN'>0 S FHCNT=0,QT="" K FHCLR F FHI=0:0 S FHI=$O(^TMP($J,FHPTNM,FHDFN,FHI)) D:FHI'>0 ASK Q:QT=U D CL2
- G CL0
- ;
- CL2 I FHI'>0 S QT=U Q
- S FHTF=$G(^FH(119,FHDUZ,"I",FHI,0))
- S DTP=$P(FHTF,"^",1),TYP=$P(FHTF,"^",2),X=$P(FHTF,"^",3),DFN=$P(FHTF,"^",4),ADM=$P(FHTF,"^",5)
- S CNT=CNT+1
- I DFN,ADM S FHWRD=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",8)
- D:'FHCNT HDR
- S FHCNT=FHCNT+1
- S FHCLR(TYP,FHCNT)=FHI
- S Y=DTP X ^DD("DD")
- W !,FHCNT,".",?4,$P(FHTF,U,3)," Date: ",Y
- Q
- ASK W !!,"Select an entry to clear (1,2,3... or 'A' or Return): Return// " R FHNM:DTIME I '$T!(FHNM["^") S FHQT=U Q
- I FHNM="" S QT=U Q
- S X=FHNM D TR^FH S FHNM=X
- S FHASK=0 K FHCHK
- I FHNM'="A" S FHTYP="" D
- .F S FHTYP=$O(FHCLR(FHTYP)) Q:FHTYP="" F FHI=0:0 S FHI=$O(FHCLR(FHTYP,FHI)) Q:FHI'>0 S FHCHK(FHI)=""
- .F FHENT=1:1 S FHNUM=$P(FHNM,",",FHENT) Q:FHNUM="" D
- ..I '$D(FHCHK(FHNUM)) W *7,!!,"Enter an entry, or group of entries separated by a comma, or 'A' for all entries, or Return to bypass!" S FHASK=1
- G:FHASK ASK
- S (FHTYPSV,FHTYP)=""
- I FHNM="A" F S FHTYP=$O(FHCLR(FHTYP)) G:FHTYP="" D1 D:(FHTYPSV'="")&(FHTYP'=FHTYPSV) D1 D
- .K FHIEN F FHII=0:0 S FHII=$O(FHCLR(FHTYP,FHII)) Q:FHII'>0 S FHTYPSV=FHTYP,FHIEN(FHCLR(FHTYP,FHII))=""
- I FHNM'="A" F S FHTYP=$O(FHCLR(FHTYP)) G:FHTYP="" D1 D:(FHTYPSV'="")&(FHTYP'=FHTYPSV) D1 D
- .K FHIEN F FHENT=1:1 S FHII=$P(FHNM,",",FHENT) Q:FHII="" S FHTYPSV=FHTYP I $D(FHCLR(FHTYP,FHII)) S FHIEN(FHCLR(FHTYP,FHII))=""
- Q
- D1 ;
- S FHTICK=$O(FHIEN(0))
- Q:'FHTICK
- S FHTF=$G(^FH(119,FHDUZ,"I",FHTICK,0)) D D2
- Q:QT=U
- F LLL=0:0 S LLL=$O(FHIEN(LLL)) Q:LLL'>0 D
- .S FHTF=$G(^FH(119,FHDUZ,"I",LLL,0)),DTP=$P(FHTF,"^",1),TYP=$P(FHTF,"^",2),X=$P(FHTF,"^",3),DFN=$P(FHTF,"^",4),ADM=$P(FHTF,"^",5)
- .D:FHTYPSV'="C" @FHTYPSV
- G DNE
- ;
- S S:NO $P(^FHPT(FHDFN,"A",ADM,"SF",NO,0),"^",30,31)=NOW_"^"_DUZ
- K ^FH(119,FHDUZ,"I",LLL)
- Q
- C ;
- Q
- D S:FHORD $P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",16,17)=NOW_"^"_DUZ
- K ^FH(119,FHDUZ,"I",LLL)
- Q
- T S:TF $P(^FHPT(FHDFN,"A",ADM,"TF",TF,0),"^",15,16)=NOW_"^"_DUZ
- K ^FH(119,FHDUZ,"I",LLL)
- Q
- N I F1,$D(^FHPT(FHDFN,"S",F1,0)) S $P(^FHPT(FHDFN,"S",F1,0),"^",4,5)=NOW_"^"_DUZ
- K ^FH(119,FHDUZ,"I",LLL)
- Q
- M ;
- S F1=$P(FHTF,"^",6) S $P(^FHPT(FHDFN,"A",ADM,"MO",F1,0),"^",3,5)=MOCOM_"^"_DUZ_"^"_NOW
- K ^FH(119,FHDUZ,"I",LLL)
- Q
- ;
- D2 S DTP=$P(FHTF,"^",1),TYP=$P(FHTF,"^",2),X=$P(FHTF,"^",3),DFN=$P(FHTF,"^",4),ADM=$P(FHTF,"^",5)
- S CNT=CNT+1
- I DFN,ADM S FHWRD=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",8)
- D SF:TYP="S",CN:TYP="C",DI:TYP="D",TF:TYP="T",NS:TYP="N",MO:TYP="M" Q
- SF ; Clear Supplemental Feeding
- S NO=$P(FHTF,"^",6)
- D CUR^FHORD7
- W !!,"Current Diet: ",$S(Y'="":Y,1:"No current order")
- S Y=$S('NO:"",1:$G(^FHPT(FHDFN,"A",ADM,"SF",NO,0))) D L1^FHNO7
- S1 R !!,"Is Order OK? Y// ",YN:DTIME S:'$T!(YN["^") QT="^" Q:QT="^" S:YN="" YN="Y" S X=YN D TR^FH S YN=X I $P("YES",YN,1)'="",$P("NO",YN,1)'="" W *7," Answer YES or NO" G S1
- S YN=$E(YN,1) I YN'="Y" S QT=U
- Q
- CN ; Clear Consult
- S FHDR=$P(FHTF,"^",6),Y=^FHPT(FHDFN,"A",ADM,"DR",FHDR,0),ALL=0
- D D1^FHORC2
- C1 R !!,"Disposition (C=Complete, X=Cancelled, R=Reassign, RETURN to bypass): ",TYP:DTIME S:'$T!(TYP["^") QT="^" Q:"^"[TYP S X=TYP D TR^FH S TYP=X I TYP'?1U!("XCR"'[TYP) W *7,!,"Enter C, X or R or Press RETURN to bypass" G C1
- I TYP="R" G C2
- C11 I ORIFN S ORSTS=TYP="C"+1 D ST^ORX
- K ^FHPT("ADRU",FHDUZ,FHDFN,ADM,FHDR)
- S $P(^FHPT(FHDFN,"A",ADM,"DR",FHDR,0),"^",8,10)=TYP_"^"_NOW_"^"_DUZ K ^FH(119,FHDUZ,"I",LLL)
- D:TYP="C" EN31^FHASE G DNE
- C2 K DIC S DIC="^VA(200,",DIC(0)="AEQM",DIC("A")="REASSIGN to Clinician: " W ! D ^DIC S:$D(DTOUT) QT="^" Q:Y<1 S XMKK=+Y K DIC
- K ^FHPT("ADRU",FHDUZ,FHDFN,ADM,FHDR) S ^FHPT("ADRU",XMKK,FHDFN,ADM,FHDR)=""
- S $P(^FHPT(FHDFN,"A",ADM,"DR",FHDR,0),"^",5)=XMKK
- K ^FH(119,FHDUZ,"I",LLL) S FHSV=FHDUZ,FHDUZ=XMKK D FILE^FHCTF2 S FHDUZ=FHSV
- S WARD=""
- I FHWRD S WARD=$P($G(^FH(119.6,+FHWRD,0)),"^",1)
- S REQ=CON D POST^FHORC
- G DNE
- Q
- ;
- TF ; Tubefeed
- S TF=$P(FHTF,"^",6)
- D DIS^FHORT2
- T1 R !!,"Is Order OK? Y// ",YN:DTIME S:'$T!(YN["^") QT="^" Q:QT="^" S:YN="" YN="Y" S X=YN D TR^FH S YN=X I $P("YES",YN,1)'="",$P("NO",YN,1)'="" W *7," Answer YES or NO" G T1
- S YN=$E(YN,1) I YN'="Y" S QT=U
- Q
- DI ; Diet
- S FHORD=$P(FHTF,"^",6)
- I FHORD D C2^FHORD7 W !!,"Current Diet: ",$S(Y'="":Y,1:"No current order")
- I 'FHORD W !!,"No current order"
- I FHORD,$D(^FHPT(FHDFN,"A",ADM,"DI",FHORD,1)) S COM=^(1) W:COM'="" !,"Comment: ",COM
- S TYS=$P(X,"^",8) I TYS'="" W !,"Service: ",$S(TYS="T":"Tray",TYS="D":"Dining Room",1:"Cafeteria")
- S DTP=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",3) I DTP D DTP^FH W !,"Expires: ",DTP
- R !!,"Is Order OK? Y// ",YN:DTIME S:'$T!(YN["^") QT="^" Q:QT="^" S:YN="" YN="Y" S X=YN D TR^FH S YN=X I $P("YES",YN,1)'="",$P("NO",YN,1)'="" W *7," Answer YES or NO" G D1
- S YN=$E(YN,1) I YN'="Y" S QT=U
- Q
- NS ; Status
- S F1=$P(FHTF,"^",6),Y=$G(^FHPT(FHDFN,"S",+F1,0)) Q:Y="" S S=$P(Y,"^",2)
- W !!,"Current Status: ",$P($G(^FH(115.4,+S,0)),"^",2)
- N1 R !!,"Is Status OK? Y// ",YN:DTIME S:'$T!(YN["^") QT="^" Q:QT="^" S:YN="" YN="Y" S X=YN D TR^FH S YN=X I $P("YES",YN,1)'="",$P("NO",YN,1)'="" W *7," Answer YES or NO" G N1
- S YN=$E(YN,1) I YN'="Y" S QT=U
- Q
- MO ; Monitor
- W !!,$P(FHTF,"^",3)
- M1 S MOCOM="" R !!,"Action Taken: ",MOCOM:DTIME S:MOCOM="^" QT="^" Q:'$T!(MOCOM["^") I MOCOM'?.ANP W *7," ??" G M1
- I MOCOM=""!($L(MOCOM)>60)!(MOCOM?1"?".E) W *7,!,"Required entry: document action (up to 60 characters) or ^ to bypass." G M1
- Q
- DNE W " ... done" Q
- HDR S DFN=$P($G(^FHPT(FHDFN,0)),U,1),DFN=$E(DFN,2,99) Q:'DFN S Y0=$G(^DPT(DFN,0)) W !!!,$P(Y0,"^",1) D PID^FHDPA W:BID'="" " (",BID,")"
- W ?40,$S($P(Y0,"^",2)="F":"Female",1:"Male")
- S AGE=$P(Y0,"^",3) I AGE'="" S AGE=$E(DT,1,3)-$E(AGE,1,3)-($E(DT,4,7)<$E(AGE,4,7)) W " Age ",AGE
- S WARD=""
- I FHWRD S WARD=$P($G(^FH(119.6,+FHWRD,0)),"^",1)
- S X=WARD_" "_$P($G(^DPT(DFN,.101)),"^",1) W ?(79-$L(X)),X
- W !,LN
- Q
- HDR1 S X=$S(TYP="S":"SUPPLEMENTAL FEEDING",TYP="C":"DIETETIC CONSULTATION",TYP="D":"DIET ORDER",TYP="T":"TUBEFEEDING",TYP="N":"NUTRITION STATUS",TYP="M":"MONITOR",1:"")
- Q
- KIL ;clean variables
- K ^TMP($J),ADM,AGE,BID,CNT,DFN,FHAGE,FHBID,FHCLR,FHCNT,FHDFN,FHDOB,FHDUZ,FHI,FHNM,FHPCZN,FHPTNM,FHQT,FHSEX,FHSSN,FHTF,FHWRD,FHZ115,FILE
- K IEN,FLAG,K,LLL,LN,NOW,PID,QT,TYP,W1,WARD,X,Y,YO,FHA,YN,FHORD,FHTF,DTP,DTE,A1,DDH,DIR,FHASK,FHENT,FHIEN,FHII,FHLD,FHNUM,QUAFI
- K FHOR,FHTICK,FHTYP,FHTYPSV,IEN200,REASK,TYS,MOCOM,AGE,F1,FHDR,DIC,DIR,FHSV,FHCHK,D3,Y0,ALL,T,TF2,NO,TUN,TFCOM,STR,QUA,QUASE
- K FHDU,X1,REQ,COM,FHTDAT,FHI115,I
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHCTF3 7332 printed Jan 18, 2025@02:48:35 Page 2
- FHCTF3 ; HISC/REL/NCA - Clear File Entries ;4/6/01 09:37
- +1 ;;5.5;DIETETICS;**4**;Jan 28, 2005;Build 32
- E0 KILL DIC,^TMP($JOB)
- SET DIC="^VA(200,"
- SET DIC(0)="AQEM"
- SET DIC("A")="Select CLINICIAN: "
- SET DIC("B")=$PIECE($GET(^VA(200,DUZ,0)),"^",1)
- WRITE !
- DO ^DIC
- KILL DIC
- if "^"[X!$DATA(DTOUT)
- GOTO KIL
- if Y<1
- GOTO E0
- SET FHDUZ=+Y
- +1 SET (FHQT,CNT,QT)=0
- DO NOW^%DTC
- SET NOW=%
- SET DT=NOW\1
- DO CLN^FHCTF4
- SET $PIECE(LN,"-",80)=""
- SET QT=""
- E1 FOR LLL=0:0
- SET LLL=$ORDER(^FH(119,FHDUZ,"I",LLL))
- if LLL<1
- QUIT
- SET FHTF=^(LLL,0)
- SET DFN=$PIECE(FHTF,U,4)
- SET FHZ115="P"_DFN
- DO CHECK^FHOMDPA
- IF $GET(FHDFN)
- Begin DoDot:1
- +1 DO PATNAME^FHOMUTL
- +2 SET ^TMP($JOB,FHPTNM,FHDFN,LLL)=FHDFN
- End DoDot:1
- +3 SET FHPTNM=""
- CL0 SET FHPTNM=$ORDER(^TMP($JOB,FHPTNM))
- if (FHPTNM="")!(FHQT=U)
- GOTO OUT
- GOTO CL1
- +1 ;
- OUT if FHQT=U
- GOTO KIL
- IF 'CNT
- WRITE !!,"No Tickler File Entries"
- +1 WRITE !
- GOTO KIL
- +2 ;
- CL1 FOR FHDFN=0:0
- SET FHDFN=$ORDER(^TMP($JOB,FHPTNM,FHDFN))
- if FHDFN'>0
- QUIT
- SET FHCNT=0
- SET QT=""
- KILL FHCLR
- FOR FHI=0:0
- SET FHI=$ORDER(^TMP($JOB,FHPTNM,FHDFN,FHI))
- if FHI'>0
- DO ASK
- if QT=U
- QUIT
- DO CL2
- +1 GOTO CL0
- +2 ;
- CL2 IF FHI'>0
- SET QT=U
- QUIT
- +1 SET FHTF=$GET(^FH(119,FHDUZ,"I",FHI,0))
- +2 SET DTP=$PIECE(FHTF,"^",1)
- SET TYP=$PIECE(FHTF,"^",2)
- SET X=$PIECE(FHTF,"^",3)
- SET DFN=$PIECE(FHTF,"^",4)
- SET ADM=$PIECE(FHTF,"^",5)
- +3 SET CNT=CNT+1
- +4 IF DFN
- IF ADM
- SET FHWRD=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",8)
- +5 if 'FHCNT
- DO HDR
- +6 SET FHCNT=FHCNT+1
- +7 SET FHCLR(TYP,FHCNT)=FHI
- +8 SET Y=DTP
- XECUTE ^DD("DD")
- +9 WRITE !,FHCNT,".",?4,$PIECE(FHTF,U,3)," Date: ",Y
- +10 QUIT
- ASK WRITE !!,"Select an entry to clear (1,2,3... or 'A' or Return): Return// "
- READ FHNM:DTIME
- IF '$TEST!(FHNM["^")
- SET FHQT=U
- QUIT
- +1 IF FHNM=""
- SET QT=U
- QUIT
- +2 SET X=FHNM
- DO TR^FH
- SET FHNM=X
- +3 SET FHASK=0
- KILL FHCHK
- +4 IF FHNM'="A"
- SET FHTYP=""
- Begin DoDot:1
- +5 FOR
- SET FHTYP=$ORDER(FHCLR(FHTYP))
- if FHTYP=""
- QUIT
- FOR FHI=0:0
- SET FHI=$ORDER(FHCLR(FHTYP,FHI))
- if FHI'>0
- QUIT
- SET FHCHK(FHI)=""
- +6 FOR FHENT=1:1
- SET FHNUM=$PIECE(FHNM,",",FHENT)
- if FHNUM=""
- QUIT
- Begin DoDot:2
- +7 IF '$DATA(FHCHK(FHNUM))
- WRITE *7,!!,"Enter an entry, or group of entries separated by a comma, or 'A' for all entries, or Return to bypass!"
- SET FHASK=1
- End DoDot:2
- End DoDot:1
- +8 if FHASK
- GOTO ASK
- +9 SET (FHTYPSV,FHTYP)=""
- +10 IF FHNM="A"
- FOR
- SET FHTYP=$ORDER(FHCLR(FHTYP))
- if FHTYP=""
- GOTO D1
- if (FHTYPSV'="")&(FHTYP'=FHTYPSV)
- DO D1
- Begin DoDot:1
- +11 KILL FHIEN
- FOR FHII=0:0
- SET FHII=$ORDER(FHCLR(FHTYP,FHII))
- if FHII'>0
- QUIT
- SET FHTYPSV=FHTYP
- SET FHIEN(FHCLR(FHTYP,FHII))=""
- End DoDot:1
- +12 IF FHNM'="A"
- FOR
- SET FHTYP=$ORDER(FHCLR(FHTYP))
- if FHTYP=""
- GOTO D1
- if (FHTYPSV'="")&(FHTYP'=FHTYPSV)
- DO D1
- Begin DoDot:1
- +13 KILL FHIEN
- FOR FHENT=1:1
- SET FHII=$PIECE(FHNM,",",FHENT)
- if FHII=""
- QUIT
- SET FHTYPSV=FHTYP
- IF $DATA(FHCLR(FHTYP,FHII))
- SET FHIEN(FHCLR(FHTYP,FHII))=""
- End DoDot:1
- +14 QUIT
- D1 ;
- +1 SET FHTICK=$ORDER(FHIEN(0))
- +2 if 'FHTICK
- QUIT
- +3 SET FHTF=$GET(^FH(119,FHDUZ,"I",FHTICK,0))
- DO D2
- +4 if QT=U
- QUIT
- +5 FOR LLL=0:0
- SET LLL=$ORDER(FHIEN(LLL))
- if LLL'>0
- QUIT
- Begin DoDot:1
- +6 SET FHTF=$GET(^FH(119,FHDUZ,"I",LLL,0))
- SET DTP=$PIECE(FHTF,"^",1)
- SET TYP=$PIECE(FHTF,"^",2)
- SET X=$PIECE(FHTF,"^",3)
- SET DFN=$PIECE(FHTF,"^",4)
- SET ADM=$PIECE(FHTF,"^",5)
- +7 if FHTYPSV'="C"
- DO @FHTYPSV
- End DoDot:1
- +8 GOTO DNE
- +9 ;
- S if NO
- SET $PIECE(^FHPT(FHDFN,"A",ADM,"SF",NO,0),"^",30,31)=NOW_"^"_DUZ
- +1 KILL ^FH(119,FHDUZ,"I",LLL)
- +2 QUIT
- C ;
- +1 QUIT
- D if FHORD
- SET $PIECE(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",16,17)=NOW_"^"_DUZ
- +1 KILL ^FH(119,FHDUZ,"I",LLL)
- +2 QUIT
- T if TF
- SET $PIECE(^FHPT(FHDFN,"A",ADM,"TF",TF,0),"^",15,16)=NOW_"^"_DUZ
- +1 KILL ^FH(119,FHDUZ,"I",LLL)
- +2 QUIT
- N IF F1
- IF $DATA(^FHPT(FHDFN,"S",F1,0))
- SET $PIECE(^FHPT(FHDFN,"S",F1,0),"^",4,5)=NOW_"^"_DUZ
- +1 KILL ^FH(119,FHDUZ,"I",LLL)
- +2 QUIT
- M ;
- +1 SET F1=$PIECE(FHTF,"^",6)
- SET $PIECE(^FHPT(FHDFN,"A",ADM,"MO",F1,0),"^",3,5)=MOCOM_"^"_DUZ_"^"_NOW
- +2 KILL ^FH(119,FHDUZ,"I",LLL)
- +3 QUIT
- +4 ;
- D2 SET DTP=$PIECE(FHTF,"^",1)
- SET TYP=$PIECE(FHTF,"^",2)
- SET X=$PIECE(FHTF,"^",3)
- SET DFN=$PIECE(FHTF,"^",4)
- SET ADM=$PIECE(FHTF,"^",5)
- +1 SET CNT=CNT+1
- +2 IF DFN
- IF ADM
- SET FHWRD=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",8)
- +3 if TYP="S"
- DO SF
- if TYP="C"
- DO CN
- if TYP="D"
- DO DI
- if TYP="T"
- DO TF
- if TYP="N"
- DO NS
- if TYP="M"
- DO MO
- QUIT
- SF ; Clear Supplemental Feeding
- +1 SET NO=$PIECE(FHTF,"^",6)
- +2 DO CUR^FHORD7
- +3 WRITE !!,"Current Diet: ",$SELECT(Y'="":Y,1:"No current order")
- +4 SET Y=$SELECT('NO:"",1:$GET(^FHPT(FHDFN,"A",ADM,"SF",NO,0)))
- DO L1^FHNO7
- S1 READ !!,"Is Order OK? Y// ",YN:DTIME
- if '$TEST!(YN["^")
- SET QT="^"
- if QT="^"
- QUIT
- if YN=""
- SET YN="Y"
- SET X=YN
- DO TR^FH
- SET YN=X
- IF $PIECE("YES",YN,1)'=""
- IF $PIECE("NO",YN,1)'=""
- WRITE *7," Answer YES or NO"
- GOTO S1
- +1 SET YN=$EXTRACT(YN,1)
- IF YN'="Y"
- SET QT=U
- +2 QUIT
- CN ; Clear Consult
- +1 SET FHDR=$PIECE(FHTF,"^",6)
- SET Y=^FHPT(FHDFN,"A",ADM,"DR",FHDR,0)
- SET ALL=0
- +2 DO D1^FHORC2
- C1 READ !!,"Disposition (C=Complete, X=Cancelled, R=Reassign, RETURN to bypass): ",TYP:DTIME
- if '$TEST!(TYP["^")
- SET QT="^"
- if "^"[TYP
- QUIT
- SET X=TYP
- DO TR^FH
- SET TYP=X
- IF TYP'?1U!("XCR"'[TYP)
- WRITE *7,!,"Enter C, X or R or Press RETURN to bypass"
- GOTO C1
- +1 IF TYP="R"
- GOTO C2
- C11 IF ORIFN
- SET ORSTS=TYP="C"+1
- DO ST^ORX
- +1 KILL ^FHPT("ADRU",FHDUZ,FHDFN,ADM,FHDR)
- +2 SET $PIECE(^FHPT(FHDFN,"A",ADM,"DR",FHDR,0),"^",8,10)=TYP_"^"_NOW_"^"_DUZ
- KILL ^FH(119,FHDUZ,"I",LLL)
- +3 if TYP="C"
- DO EN31^FHASE
- GOTO DNE
- C2 KILL DIC
- SET DIC="^VA(200,"
- SET DIC(0)="AEQM"
- SET DIC("A")="REASSIGN to Clinician: "
- WRITE !
- DO ^DIC
- if $DATA(DTOUT)
- SET QT="^"
- if Y<1
- QUIT
- SET XMKK=+Y
- KILL DIC
- +1 KILL ^FHPT("ADRU",FHDUZ,FHDFN,ADM,FHDR)
- SET ^FHPT("ADRU",XMKK,FHDFN,ADM,FHDR)=""
- +2 SET $PIECE(^FHPT(FHDFN,"A",ADM,"DR",FHDR,0),"^",5)=XMKK
- +3 KILL ^FH(119,FHDUZ,"I",LLL)
- SET FHSV=FHDUZ
- SET FHDUZ=XMKK
- DO FILE^FHCTF2
- SET FHDUZ=FHSV
- +4 SET WARD=""
- +5 IF FHWRD
- SET WARD=$PIECE($GET(^FH(119.6,+FHWRD,0)),"^",1)
- +6 SET REQ=CON
- DO POST^FHORC
- +7 GOTO DNE
- +8 QUIT
- +9 ;
- TF ; Tubefeed
- +1 SET TF=$PIECE(FHTF,"^",6)
- +2 DO DIS^FHORT2
- T1 READ !!,"Is Order OK? Y// ",YN:DTIME
- if '$TEST!(YN["^")
- SET QT="^"
- if QT="^"
- QUIT
- if YN=""
- SET YN="Y"
- SET X=YN
- DO TR^FH
- SET YN=X
- IF $PIECE("YES",YN,1)'=""
- IF $PIECE("NO",YN,1)'=""
- WRITE *7," Answer YES or NO"
- GOTO T1
- +1 SET YN=$EXTRACT(YN,1)
- IF YN'="Y"
- SET QT=U
- +2 QUIT
- DI ; Diet
- +1 SET FHORD=$PIECE(FHTF,"^",6)
- +2 IF FHORD
- DO C2^FHORD7
- WRITE !!,"Current Diet: ",$SELECT(Y'="":Y,1:"No current order")
- +3 IF 'FHORD
- WRITE !!,"No current order"
- +4 IF FHORD
- IF $DATA(^FHPT(FHDFN,"A",ADM,"DI",FHORD,1))
- SET COM=^(1)
- if COM'=""
- WRITE !,"Comment: ",COM
- +5 SET TYS=$PIECE(X,"^",8)
- IF TYS'=""
- WRITE !,"Service: ",$SELECT(TYS="T":"Tray",TYS="D":"Dining Room",1:"Cafeteria")
- +6 SET DTP=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",3)
- IF DTP
- DO DTP^FH
- WRITE !,"Expires: ",DTP
- +7 READ !!,"Is Order OK? Y// ",YN:DTIME
- if '$TEST!(YN["^")
- SET QT="^"
- if QT="^"
- QUIT
- if YN=""
- SET YN="Y"
- SET X=YN
- DO TR^FH
- SET YN=X
- IF $PIECE("YES",YN,1)'=""
- IF $PIECE("NO",YN,1)'=""
- WRITE *7," Answer YES or NO"
- GOTO D1
- +8 SET YN=$EXTRACT(YN,1)
- IF YN'="Y"
- SET QT=U
- +9 QUIT
- NS ; Status
- +1 SET F1=$PIECE(FHTF,"^",6)
- SET Y=$GET(^FHPT(FHDFN,"S",+F1,0))
- if Y=""
- QUIT
- SET S=$PIECE(Y,"^",2)
- +2 WRITE !!,"Current Status: ",$PIECE($GET(^FH(115.4,+S,0)),"^",2)
- N1 READ !!,"Is Status OK? Y// ",YN:DTIME
- if '$TEST!(YN["^")
- SET QT="^"
- if QT="^"
- QUIT
- if YN=""
- SET YN="Y"
- SET X=YN
- DO TR^FH
- SET YN=X
- IF $PIECE("YES",YN,1)'=""
- IF $PIECE("NO",YN,1)'=""
- WRITE *7," Answer YES or NO"
- GOTO N1
- +1 SET YN=$EXTRACT(YN,1)
- IF YN'="Y"
- SET QT=U
- +2 QUIT
- MO ; Monitor
- +1 WRITE !!,$PIECE(FHTF,"^",3)
- M1 SET MOCOM=""
- READ !!,"Action Taken: ",MOCOM:DTIME
- if MOCOM="^"
- SET QT="^"
- if '$TEST!(MOCOM["^")
- QUIT
- IF MOCOM'?.ANP
- WRITE *7," ??"
- GOTO M1
- +1 IF MOCOM=""!($LENGTH(MOCOM)>60)!(MOCOM?1"?".E)
- WRITE *7,!,"Required entry: document action (up to 60 characters) or ^ to bypass."
- GOTO M1
- +2 QUIT
- DNE WRITE " ... done"
- QUIT
- HDR SET DFN=$PIECE($GET(^FHPT(FHDFN,0)),U,1)
- SET DFN=$EXTRACT(DFN,2,99)
- if 'DFN
- QUIT
- SET Y0=$GET(^DPT(DFN,0))
- WRITE !!!,$PIECE(Y0,"^",1)
- DO PID^FHDPA
- if BID'=""
- WRITE " (",BID,")"
- +1 WRITE ?40,$SELECT($PIECE(Y0,"^",2)="F":"Female",1:"Male")
- +2 SET AGE=$PIECE(Y0,"^",3)
- IF AGE'=""
- SET AGE=$EXTRACT(DT,1,3)-$EXTRACT(AGE,1,3)-($EXTRACT(DT,4,7)<$EXTRACT(AGE,4,7))
- WRITE " Age ",AGE
- +3 SET WARD=""
- +4 IF FHWRD
- SET WARD=$PIECE($GET(^FH(119.6,+FHWRD,0)),"^",1)
- +5 SET X=WARD_" "_$PIECE($GET(^DPT(DFN,.101)),"^",1)
- WRITE ?(79-$LENGTH(X)),X
- +6 WRITE !,LN
- +7 QUIT
- HDR1 SET X=$SELECT(TYP="S":"SUPPLEMENTAL FEEDING",TYP="C":"DIETETIC CONSULTATION",TYP="D":"DIET ORDER",TYP="T":"TUBEFEEDING",TYP="N":"NUTRITION STATUS",TYP="M":"MONITOR",1:"")
- +1 QUIT
- KIL ;clean variables
- +1 KILL ^TMP($JOB),ADM,AGE,BID,CNT,DFN,FHAGE,FHBID,FHCLR,FHCNT,FHDFN,FHDOB,FHDUZ,FHI,FHNM,FHPCZN,FHPTNM,FHQT,FHSEX,FHSSN,FHTF,FHWRD,FHZ115,FILE
- +2 KILL IEN,FLAG,K,LLL,LN,NOW,PID,QT,TYP,W1,WARD,X,Y,YO,FHA,YN,FHORD,FHTF,DTP,DTE,A1,DDH,DIR,FHASK,FHENT,FHIEN,FHII,FHLD,FHNUM,QUAFI
- +3 KILL FHOR,FHTICK,FHTYP,FHTYPSV,IEN200,REASK,TYS,MOCOM,AGE,F1,FHDR,DIC,DIR,FHSV,FHCHK,D3,Y0,ALL,T,TF2,NO,TUN,TFCOM,STR,QUA,QUASE
- +4 KILL FHDU,X1,REQ,COM,FHTDAT,FHI115,I
- +5 QUIT