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 Oct 16, 2024@17:53:41 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
