- FHOMRT1 ;Hines OIFO/RTK OUTPATIENT MEALS TUBEFEEDING ORDERS ;6/02/03 14:15
- ;;5.5;DIETETICS;**1,2**;Jan 28, 2005
- ;
- S FHMSG1="T" D GETOPT^FHOMUTL I FHFIND=0 Q
- K NUM D DISP^FHOMRR1 I $G(NUM)="" Q
- TF1 W ! K DIR S DIR("A")="Select Order(s)",DIR(0)="LO^1:"_NUM D ^DIR
- Q:$D(DIRUT) S FHCLST=Y
- S FHCAN1=0 F A=1:1:NUM S FHC=$P(FHCLST,",",A) Q:FHC="" S FHRNUM=FHLIST(FHC) I $P($G(^FHPT(FHDFN,"OP",+FHRNUM,0)),U,15)'="C" S FHCAN1=1
- I FHCAN1=0 W !!?3,"The selected order(s) have been cancelled!",! D TF1 Q
- FHTUB K TUN S NO=0,FHWF=$S($D(^ORD(101)):1,1:0) D ^FHORT10
- I $O(TUN(0))="" D EXMSG^FHOMUTL Q
- S (FHTC,FHTK)=0,FHORN="" W !
- F FHK=0:0 S FHK=$O(TUN(FHK)) Q:FHK<1 D
- .S FHTC=FHTC+$P(TUN(FHK),"^",4)+$P(TUN(FHK),"^",5)
- .S FHTK=FHTK+$P(TUN(FHK),"^",6),FHSTR=$P(TUN(FHK),"^",2)
- .S FHPRO=$P(TUN(FHK),"^",1)
- .W !,"Product: ",$P($G(^FH(118.2,FHPRO,0)),"^",1),", "
- .W $S(FHSTR=4:"Full",FHSTR=2:"1/2",FHSTR=1:"1/4",1:"3/4"),", "
- .W $P(TUN(FHK),"^",3)
- .Q
- W !!,"Total Kcal: ",FHTK,?36,"Total Quantity: ",FHTC
- I FHTC>5000 W !!,"WARNING: Total amount exceeds 5000ml: ",FHTC," ml",!,"Please Edit the Tubefeeding and Modify." D FHTUB Q
- ;
- W ! K DIR S DIR("A")="Tubefeeding Comment: ",DIR(0)="FAO^1:160" D ^DIR
- I Y="^" D EXMSG^FHOMUTL Q
- S FHTEXT=Y
- W ! K DIR S DIR("A")="Is this correct?: ",DIR(0)="YA",DIR("B")="Y"
- D ^DIR I $D(DIRUT)!(Y=0) D EXMSG^FHOMUTL,END Q
- W !
- F A=1:1:NUM S FHC=$P(FHCLST,",",A) Q:FHC="" S FHRNUM=FHLIST(FHC) D CHK
- D OKMSG^FHOMUTL Q
- D END Q
- CHK ;
- I $P($G(^FHPT(FHDFN,"OP",+FHRNUM,0)),U,15)="C" S FHDTX=$P(FHRNUM,U,2),FHDTX=$$FMTE^XLFDT(FHDTX,"P") W !?3,"The order for ",$E(FHDTX,1,12)," has been cancelled -- not ordered!" Q
- D SET,UPD100
- Q
- SET ;
- K ^FHPT(FHDFN,"OP",+FHRNUM,"TF") S FHEV=""
- S FHORN=$S($G(FHORN)="":"",1:FHORN)
- K DIE S DA(1)=FHDFN,DIE="^FHPT("_DA(1)_",""OP"",",DA=+FHRNUM
- S DR="18////^S X=FHTEXT;20////^S X=FHTC;21////^S X=FHTK;21.5////^S X=FHORN;21.7////^S X=DUZ" D ^DIE
- F K=0:0 S K=$O(TUN(K)) Q:K<1 D
- .S Y=K K DIC,DO S DA(2)=FHDFN,DA(1)=+FHRNUM
- .S DIC="^FHPT("_DA(2)_",""OP"","_DA(1)_",""TF"","
- .S DIC(0)="L",DIC("P")=$P(^DD(115.016,19,0),U,2),X=+Y,DINUM=X
- .D FILE^DICN I Y=-1 Q
- .K DIE S DA(2)=FHDFN,DA(1)=+FHRNUM,DA=+Y
- .S FH1=$P(TUN(K),U,2),FH2=$P(TUN(K),U,3),FH3=$P(TUN(K),U,4)
- .S FH4=$P(TUN(K),U,5),FH5=$P(TUN(K),U,6)
- .S DIE="^FHPT("_DA(2)_",""OP"","_DA(1)_",""TF"","
- .S DR="1////^S X=FH1;2////^S X=FH2;3////^S X=FH3;4////^S X=FH4;5////^S X=FH5" D ^DIE
- .S X3=TUN(K),TUN=$P(X3,U,1),XX=$G(^FH(118.2,TUN,0)) D CALC^FHORX3
- .S FHEV=FHEV_P2_" "_$P(XX,"^",1)_", "
- .Q
- S FHACT="O",FHOPTY="T",FHAET=$E(FHEV,1,$L(FHEV)-2) D SETAET^FHOMRO2
- Q
- END ;
- K A,FHFIND,FHCLST,FHC,FHRNUM,FHTEXT,FHTODAY,NUM Q
- Q
- HL7SET ;
- ; Entry point for TF's placed from CPRS/OERR
- K TUN S (NO,TC,TK,TP,TW,S2)=0,CTR=5
- F NUM=1:1:5 S DATA=$G(FHMSG(CTR)) Q:DATA="" S CTR=CTR+1,DATA1=$G(FHMSG(CTR)) Q:DATA1="" D ^FHWOR51 S CTR=CTR+1 Q:TXT'=""
- I TXT'="" D ERR^FHOMWOR Q
- I $O(TUN(0))="" Q
- S (FHCOND,FHTC,FHTK)=0,FHTEXT=$E($P(DATA,"|",5),1,160)
- F FHK=0:0 S FHK=$O(TUN(FHK)) Q:FHK<1!(FHCOND=1) D
- .I '$D(^FH(118.2,FHK)) S FHCOND=1 Q
- .S FHTC=FHTC+$P(TUN(FHK),"^",4)+$P(TUN(FHK),"^",5)
- .S FHTK=FHTK+$P(TUN(FHK),"^",6)
- .Q
- I FHCOND=1 S TXT="Invalid TF Product" D GETOR^FHWOR,ERR^FHOMWOR Q
- I FHTC>5000 S TXT="Total amount exceeds 5000ml" D ERR^FHOMWOR Q
- S X1=STDT,X2=-1 D C^%DTC S STDT1=X
- F FHRMDT=STDT1:0 S FHRMDT=$O(^FHPT(FHDFN,"OP","B",FHRMDT)) Q:FHRMDT'>0!(FHRMDT>ENDT) F FHRNUM=0:0 S FHRNUM=$O(^FHPT(FHDFN,"OP","B",FHRMDT,FHRNUM)) Q:FHRNUM'>0 D SET
- I '$D(FHRNUM) Q
- S FILL="T;"_FHRNUM_";"_FHTK_";"_FHTC_";"_FHTEXT_";"_FHORN
- D SEND^FHWOR Q
- UPD100 ;Backdoor message to update file #100 with a new TF order
- Q:'$$PATCH^XPDUTL("OR*3.0*215") ;must have CPRSv26 for O.M. backdoor
- Q:'DFN K MSG D MSHOM^FHOMUTL ;Sets MSG(1), MSG(2) & MSG(3) for OM
- S FILL="T;"_FHRNUM,MNUM=4,TFCOM=FHTEXT D NOW^%DTC S FHNOW=%
- S (FHODT,SDT)=$P(FHRNUM,U,2),FHODT=$$FMTHL7^XLFDT(FHODT)
- S MSG(MNUM)="ORC|SN||"_FILL_"^FH||||^^^"_FHODT_"|||"_DUZ_"||"_DUZ_"|||"_FHNOW
- F FHTF=0:0 S FHTF=$O(TUN(FHTF)) Q:FHTF<1 S XX=$G(TUN(FHTF)) D TF1^FHWOR5
- D EVSEND^FHWOR
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHOMRT1 4168 printed Jan 18, 2025@02:54:17 Page 2
- FHOMRT1 ;Hines OIFO/RTK OUTPATIENT MEALS TUBEFEEDING ORDERS ;6/02/03 14:15
- +1 ;;5.5;DIETETICS;**1,2**;Jan 28, 2005
- +2 ;
- +3 SET FHMSG1="T"
- DO GETOPT^FHOMUTL
- IF FHFIND=0
- QUIT
- +4 KILL NUM
- DO DISP^FHOMRR1
- IF $GET(NUM)=""
- QUIT
- TF1 WRITE !
- KILL DIR
- SET DIR("A")="Select Order(s)"
- SET DIR(0)="LO^1:"_NUM
- DO ^DIR
- +1 if $DATA(DIRUT)
- QUIT
- SET FHCLST=Y
- +2 SET FHCAN1=0
- FOR A=1:1:NUM
- SET FHC=$PIECE(FHCLST,",",A)
- if FHC=""
- QUIT
- SET FHRNUM=FHLIST(FHC)
- IF $PIECE($GET(^FHPT(FHDFN,"OP",+FHRNUM,0)),U,15)'="C"
- SET FHCAN1=1
- +3 IF FHCAN1=0
- WRITE !!?3,"The selected order(s) have been cancelled!",!
- DO TF1
- QUIT
- FHTUB KILL TUN
- SET NO=0
- SET FHWF=$SELECT($DATA(^ORD(101)):1,1:0)
- DO ^FHORT10
- +1 IF $ORDER(TUN(0))=""
- DO EXMSG^FHOMUTL
- QUIT
- +2 SET (FHTC,FHTK)=0
- SET FHORN=""
- WRITE !
- +3 FOR FHK=0:0
- SET FHK=$ORDER(TUN(FHK))
- if FHK<1
- QUIT
- Begin DoDot:1
- +4 SET FHTC=FHTC+$PIECE(TUN(FHK),"^",4)+$PIECE(TUN(FHK),"^",5)
- +5 SET FHTK=FHTK+$PIECE(TUN(FHK),"^",6)
- SET FHSTR=$PIECE(TUN(FHK),"^",2)
- +6 SET FHPRO=$PIECE(TUN(FHK),"^",1)
- +7 WRITE !,"Product: ",$PIECE($GET(^FH(118.2,FHPRO,0)),"^",1),", "
- +8 WRITE $SELECT(FHSTR=4:"Full",FHSTR=2:"1/2",FHSTR=1:"1/4",1:"3/4"),", "
- +9 WRITE $PIECE(TUN(FHK),"^",3)
- +10 QUIT
- End DoDot:1
- +11 WRITE !!,"Total Kcal: ",FHTK,?36,"Total Quantity: ",FHTC
- +12 IF FHTC>5000
- WRITE !!,"WARNING: Total amount exceeds 5000ml: ",FHTC," ml",!,"Please Edit the Tubefeeding and Modify."
- DO FHTUB
- QUIT
- +13 ;
- +14 WRITE !
- KILL DIR
- SET DIR("A")="Tubefeeding Comment: "
- SET DIR(0)="FAO^1:160"
- DO ^DIR
- +15 IF Y="^"
- DO EXMSG^FHOMUTL
- QUIT
- +16 SET FHTEXT=Y
- +17 WRITE !
- KILL DIR
- SET DIR("A")="Is this correct?: "
- SET DIR(0)="YA"
- SET DIR("B")="Y"
- +18 DO ^DIR
- IF $DATA(DIRUT)!(Y=0)
- DO EXMSG^FHOMUTL
- DO END
- QUIT
- +19 WRITE !
- +20 FOR A=1:1:NUM
- SET FHC=$PIECE(FHCLST,",",A)
- if FHC=""
- QUIT
- SET FHRNUM=FHLIST(FHC)
- DO CHK
- +21 DO OKMSG^FHOMUTL
- QUIT
- +22 DO END
- QUIT
- CHK ;
- +1 IF $PIECE($GET(^FHPT(FHDFN,"OP",+FHRNUM,0)),U,15)="C"
- SET FHDTX=$PIECE(FHRNUM,U,2)
- SET FHDTX=$$FMTE^XLFDT(FHDTX,"P")
- WRITE !?3,"The order for ",$EXTRACT(FHDTX,1,12)," has been cancelled -- not ordered!"
- QUIT
- +2 DO SET
- DO UPD100
- +3 QUIT
- SET ;
- +1 KILL ^FHPT(FHDFN,"OP",+FHRNUM,"TF")
- SET FHEV=""
- +2 SET FHORN=$SELECT($GET(FHORN)="":"",1:FHORN)
- +3 KILL DIE
- SET DA(1)=FHDFN
- SET DIE="^FHPT("_DA(1)_",""OP"","
- SET DA=+FHRNUM
- +4 SET DR="18////^S X=FHTEXT;20////^S X=FHTC;21////^S X=FHTK;21.5////^S X=FHORN;21.7////^S X=DUZ"
- DO ^DIE
- +5 FOR K=0:0
- SET K=$ORDER(TUN(K))
- if K<1
- QUIT
- Begin DoDot:1
- +6 SET Y=K
- KILL DIC,DO
- SET DA(2)=FHDFN
- SET DA(1)=+FHRNUM
- +7 SET DIC="^FHPT("_DA(2)_",""OP"","_DA(1)_",""TF"","
- +8 SET DIC(0)="L"
- SET DIC("P")=$PIECE(^DD(115.016,19,0),U,2)
- SET X=+Y
- SET DINUM=X
- +9 DO FILE^DICN
- IF Y=-1
- QUIT
- +10 KILL DIE
- SET DA(2)=FHDFN
- SET DA(1)=+FHRNUM
- SET DA=+Y
- +11 SET FH1=$PIECE(TUN(K),U,2)
- SET FH2=$PIECE(TUN(K),U,3)
- SET FH3=$PIECE(TUN(K),U,4)
- +12 SET FH4=$PIECE(TUN(K),U,5)
- SET FH5=$PIECE(TUN(K),U,6)
- +13 SET DIE="^FHPT("_DA(2)_",""OP"","_DA(1)_",""TF"","
- +14 SET DR="1////^S X=FH1;2////^S X=FH2;3////^S X=FH3;4////^S X=FH4;5////^S X=FH5"
- DO ^DIE
- +15 SET X3=TUN(K)
- SET TUN=$PIECE(X3,U,1)
- SET XX=$GET(^FH(118.2,TUN,0))
- DO CALC^FHORX3
- +16 SET FHEV=FHEV_P2_" "_$PIECE(XX,"^",1)_", "
- +17 QUIT
- End DoDot:1
- +18 SET FHACT="O"
- SET FHOPTY="T"
- SET FHAET=$EXTRACT(FHEV,1,$LENGTH(FHEV)-2)
- DO SETAET^FHOMRO2
- +19 QUIT
- END ;
- +1 KILL A,FHFIND,FHCLST,FHC,FHRNUM,FHTEXT,FHTODAY,NUM
- QUIT
- +2 QUIT
- HL7SET ;
- +1 ; Entry point for TF's placed from CPRS/OERR
- +2 KILL TUN
- SET (NO,TC,TK,TP,TW,S2)=0
- SET CTR=5
- +3 FOR NUM=1:1:5
- SET DATA=$GET(FHMSG(CTR))
- if DATA=""
- QUIT
- SET CTR=CTR+1
- SET DATA1=$GET(FHMSG(CTR))
- if DATA1=""
- QUIT
- DO ^FHWOR51
- SET CTR=CTR+1
- if TXT'=""
- QUIT
- +4 IF TXT'=""
- DO ERR^FHOMWOR
- QUIT
- +5 IF $ORDER(TUN(0))=""
- QUIT
- +6 SET (FHCOND,FHTC,FHTK)=0
- SET FHTEXT=$EXTRACT($PIECE(DATA,"|",5),1,160)
- +7 FOR FHK=0:0
- SET FHK=$ORDER(TUN(FHK))
- if FHK<1!(FHCOND=1)
- QUIT
- Begin DoDot:1
- +8 IF '$DATA(^FH(118.2,FHK))
- SET FHCOND=1
- QUIT
- +9 SET FHTC=FHTC+$PIECE(TUN(FHK),"^",4)+$PIECE(TUN(FHK),"^",5)
- +10 SET FHTK=FHTK+$PIECE(TUN(FHK),"^",6)
- +11 QUIT
- End DoDot:1
- +12 IF FHCOND=1
- SET TXT="Invalid TF Product"
- DO GETOR^FHWOR
- DO ERR^FHOMWOR
- QUIT
- +13 IF FHTC>5000
- SET TXT="Total amount exceeds 5000ml"
- DO ERR^FHOMWOR
- QUIT
- +14 SET X1=STDT
- SET X2=-1
- DO C^%DTC
- SET STDT1=X
- +15 FOR FHRMDT=STDT1:0
- SET FHRMDT=$ORDER(^FHPT(FHDFN,"OP","B",FHRMDT))
- if FHRMDT'>0!(FHRMDT>ENDT)
- QUIT
- FOR FHRNUM=0:0
- SET FHRNUM=$ORDER(^FHPT(FHDFN,"OP","B",FHRMDT,FHRNUM))
- if FHRNUM'>0
- QUIT
- DO SET
- +16 IF '$DATA(FHRNUM)
- QUIT
- +17 SET FILL="T;"_FHRNUM_";"_FHTK_";"_FHTC_";"_FHTEXT_";"_FHORN
- +18 DO SEND^FHWOR
- QUIT
- UPD100 ;Backdoor message to update file #100 with a new TF order
- +1 ;must have CPRSv26 for O.M. backdoor
- if '$$PATCH^XPDUTL("OR*3.0*215")
- QUIT
- +2 ;Sets MSG(1), MSG(2) & MSG(3) for OM
- if 'DFN
- QUIT
- KILL MSG
- DO MSHOM^FHOMUTL
- +3 SET FILL="T;"_FHRNUM
- SET MNUM=4
- SET TFCOM=FHTEXT
- DO NOW^%DTC
- SET FHNOW=%
- +4 SET (FHODT,SDT)=$PIECE(FHRNUM,U,2)
- SET FHODT=$$FMTHL7^XLFDT(FHODT)
- +5 SET MSG(MNUM)="ORC|SN||"_FILL_"^FH||||^^^"_FHODT_"|||"_DUZ_"||"_DUZ_"|||"_FHNOW
- +6 FOR FHTF=0:0
- SET FHTF=$ORDER(TUN(FHTF))
- if FHTF<1
- QUIT
- SET XX=$GET(TUN(FHTF))
- DO TF1^FHWOR5
- +7 DO EVSEND^FHWOR
- +8 QUIT