- FHOMRA1 ;Hines OIFO/RTK OUTPATIENT MEALS ADDITIONAL ORDERS ;5/14/03 15:15
- ;;5.5;DIETETICS;**2**;Jan 28, 2005
- ;
- S FHMSG1="A" D GETOPT^FHOMUTL I FHFIND=0 Q
- K NUM D DISP^FHOMRR1 I $G(NUM)="" Q
- AO1 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 AO1 Q
- W ! K DIR S DIR("A")="Additional Order: ",DIR(0)="FAO^1:160" D ^DIR
- I $D(DIRUT) 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
- 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 ;
- D NOW^%DTC S FHTODAY=$E(%,1,12)
- S FHORN=$S($G(FHORN)="":"",1:FHORN)
- K DIE S DA(1)=FHDFN,DIE="^FHPT("_DA(1)_",""OP"",",DA=+FHRNUM
- S DR="11////^S X=FHTEXT;12////^S X=DUZ;13////^S X=FHTODAY;13.5////^S X=FHORN" D ^DIE
- S FHACT="O",FHOPTY="A",FHAET=FHTEXT D SETAET^FHOMRO2
- Q
- END ;
- K A,FHFIND,FHCLST,FHC,FHRNUM,FHTEXT,FHTODAY,NUM Q
- HL7SET ;
- ; Entry point for AO's placed from CPRS/OERR
- S FHTEXT=FHCOM,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="A;"_FHRNUM_";"_FHCOM_";"_FHORN
- D SEND^FHWOR Q
- UPD100 ;Backdoor message to update file #100 with a new AO 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="A;"_FHRNUM,FHODT=$P(FHRNUM,U,2),FHODT=$$FMTHL7^XLFDT(FHODT)
- S MSG(4)="ORC|SN||"_FILL_"^FH||||^^^"_FHODT_"^"_FHODT_"||||||||"_FHTODAY
- S MSG(5)="ODS|D||^^^FH-6^Additional Order^99OTH|"_FHTEXT
- D EVSEND^FHWOR
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHOMRA1 2189 printed Jan 18, 2025@02:54:04 Page 2
- FHOMRA1 ;Hines OIFO/RTK OUTPATIENT MEALS ADDITIONAL ORDERS ;5/14/03 15:15
- +1 ;;5.5;DIETETICS;**2**;Jan 28, 2005
- +2 ;
- +3 SET FHMSG1="A"
- DO GETOPT^FHOMUTL
- IF FHFIND=0
- QUIT
- +4 KILL NUM
- DO DISP^FHOMRR1
- IF $GET(NUM)=""
- QUIT
- AO1 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 AO1
- QUIT
- +4 WRITE !
- KILL DIR
- SET DIR("A")="Additional Order: "
- SET DIR(0)="FAO^1:160"
- DO ^DIR
- +5 IF $DATA(DIRUT)
- DO EXMSG^FHOMUTL
- QUIT
- +6 SET FHTEXT=Y
- +7 WRITE !
- KILL DIR
- SET DIR("A")="Is this correct?: "
- SET DIR(0)="YA"
- SET DIR("B")="Y"
- +8 DO ^DIR
- IF $DATA(DIRUT)!(Y=0)
- DO EXMSG^FHOMUTL
- DO END
- QUIT
- +9 WRITE !
- +10 FOR A=1:1:NUM
- SET FHC=$PIECE(FHCLST,",",A)
- if FHC=""
- QUIT
- SET FHRNUM=FHLIST(FHC)
- DO CHK
- +11 DO OKMSG^FHOMUTL
- +12 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 DO NOW^%DTC
- SET FHTODAY=$EXTRACT(%,1,12)
- +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="11////^S X=FHTEXT;12////^S X=DUZ;13////^S X=FHTODAY;13.5////^S X=FHORN"
- DO ^DIE
- +5 SET FHACT="O"
- SET FHOPTY="A"
- SET FHAET=FHTEXT
- DO SETAET^FHOMRO2
- +6 QUIT
- END ;
- +1 KILL A,FHFIND,FHCLST,FHC,FHRNUM,FHTEXT,FHTODAY,NUM
- QUIT
- HL7SET ;
- +1 ; Entry point for AO's placed from CPRS/OERR
- +2 SET FHTEXT=FHCOM
- SET X1=STDT
- SET X2=-1
- DO C^%DTC
- SET STDT1=X
- +3 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
- +4 IF '$DATA(FHRNUM)
- QUIT
- +5 SET FILL="A;"_FHRNUM_";"_FHCOM_";"_FHORN
- +6 DO SEND^FHWOR
- QUIT
- UPD100 ;Backdoor message to update file #100 with a new AO 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="A;"_FHRNUM
- SET FHODT=$PIECE(FHRNUM,U,2)
- SET FHODT=$$FMTHL7^XLFDT(FHODT)
- +4 SET MSG(4)="ORC|SN||"_FILL_"^FH||||^^^"_FHODT_"^"_FHODT_"||||||||"_FHTODAY
- +5 SET MSG(5)="ODS|D||^^^FH-6^Additional Order^99OTH|"_FHTEXT
- +6 DO EVSEND^FHWOR
- +7 QUIT