Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FHOMRA1

FHOMRA1.m

Go to the documentation of this file.
  1. FHOMRA1 ;Hines OIFO/RTK OUTPATIENT MEALS ADDITIONAL ORDERS ;5/14/03 15:15
  1. ;;5.5;DIETETICS;**2**;Jan 28, 2005
  1. ;
  1. S FHMSG1="A" D GETOPT^FHOMUTL I FHFIND=0 Q
  1. K NUM D DISP^FHOMRR1 I $G(NUM)="" Q
  1. AO1 W ! K DIR S DIR("A")="Select Order(s)",DIR(0)="LO^1:"_NUM D ^DIR
  1. Q:$D(DIRUT) S FHCLST=Y
  1. 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
  1. I FHCAN1=0 W !!?3,"The selected order(s) have been cancelled!",! D AO1 Q
  1. W ! K DIR S DIR("A")="Additional Order: ",DIR(0)="FAO^1:160" D ^DIR
  1. I $D(DIRUT) D EXMSG^FHOMUTL Q
  1. S FHTEXT=Y
  1. W ! K DIR S DIR("A")="Is this correct?: ",DIR(0)="YA",DIR("B")="Y"
  1. D ^DIR I $D(DIRUT)!(Y=0) D EXMSG^FHOMUTL,END Q
  1. W !
  1. F A=1:1:NUM S FHC=$P(FHCLST,",",A) Q:FHC="" S FHRNUM=FHLIST(FHC) D CHK
  1. D OKMSG^FHOMUTL
  1. D END Q
  1. CHK ;
  1. 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
  1. D SET,UPD100
  1. Q
  1. SET ;
  1. D NOW^%DTC S FHTODAY=$E(%,1,12)
  1. S FHORN=$S($G(FHORN)="":"",1:FHORN)
  1. K DIE S DA(1)=FHDFN,DIE="^FHPT("_DA(1)_",""OP"",",DA=+FHRNUM
  1. S DR="11////^S X=FHTEXT;12////^S X=DUZ;13////^S X=FHTODAY;13.5////^S X=FHORN" D ^DIE
  1. S FHACT="O",FHOPTY="A",FHAET=FHTEXT D SETAET^FHOMRO2
  1. Q
  1. END ;
  1. K A,FHFIND,FHCLST,FHC,FHRNUM,FHTEXT,FHTODAY,NUM Q
  1. HL7SET ;
  1. ; Entry point for AO's placed from CPRS/OERR
  1. S FHTEXT=FHCOM,X1=STDT,X2=-1 D C^%DTC S STDT1=X
  1. 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
  1. I '$D(FHRNUM) Q
  1. S FILL="A;"_FHRNUM_";"_FHCOM_";"_FHORN
  1. D SEND^FHWOR Q
  1. UPD100 ;Backdoor message to update file #100 with a new AO order
  1. Q:'$$PATCH^XPDUTL("OR*3.0*215") ;must have CPRSv26 for O.M. backdoor
  1. Q:'DFN K MSG D MSHOM^FHOMUTL ;Sets MSG(1), MSG(2) & MSG(3) for OM
  1. S FILL="A;"_FHRNUM,FHODT=$P(FHRNUM,U,2),FHODT=$$FMTHL7^XLFDT(FHODT)
  1. S MSG(4)="ORC|SN||"_FILL_"^FH||||^^^"_FHODT_"^"_FHODT_"||||||||"_FHTODAY
  1. S MSG(5)="ODS|D||^^^FH-6^Additional Order^99OTH|"_FHTEXT
  1. D EVSEND^FHWOR
  1. Q