source: FOIAVistA/trunk/r/DIETETICS-FH/FHOMRA1.m@ 1806

Last change on this file since 1806 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 2.1 KB
Line 
1FHOMRA1 ;Hines OIFO/RTK OUTPATIENT MEALS ADDITIONAL ORDERS ;5/14/03 15:15
2 ;;5.5;DIETETICS;**2**;Jan 28, 2005
3 ;
4 S FHMSG1="A" D GETOPT^FHOMUTL I FHFIND=0 Q
5 K NUM D DISP^FHOMRR1 I $G(NUM)="" Q
6AO1 W ! K DIR S DIR("A")="Select Order(s)",DIR(0)="LO^1:"_NUM D ^DIR
7 Q:$D(DIRUT) S FHCLST=Y
8 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
9 I FHCAN1=0 W !!?3,"The selected order(s) have been cancelled!",! D AO1 Q
10 W ! K DIR S DIR("A")="Additional Order: ",DIR(0)="FAO^1:160" D ^DIR
11 I $D(DIRUT) D EXMSG^FHOMUTL Q
12 S FHTEXT=Y
13 W ! K DIR S DIR("A")="Is this correct?: ",DIR(0)="YA",DIR("B")="Y"
14 D ^DIR I $D(DIRUT)!(Y=0) D EXMSG^FHOMUTL,END Q
15 W !
16 F A=1:1:NUM S FHC=$P(FHCLST,",",A) Q:FHC="" S FHRNUM=FHLIST(FHC) D CHK
17 D OKMSG^FHOMUTL
18 D END Q
19CHK ;
20 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
21 D SET,UPD100
22 Q
23SET ;
24 D NOW^%DTC S FHTODAY=$E(%,1,12)
25 S FHORN=$S($G(FHORN)="":"",1:FHORN)
26 K DIE S DA(1)=FHDFN,DIE="^FHPT("_DA(1)_",""OP"",",DA=+FHRNUM
27 S DR="11////^S X=FHTEXT;12////^S X=DUZ;13////^S X=FHTODAY;13.5////^S X=FHORN" D ^DIE
28 S FHACT="O",FHOPTY="A",FHAET=FHTEXT D SETAET^FHOMRO2
29 Q
30END ;
31 K A,FHFIND,FHCLST,FHC,FHRNUM,FHTEXT,FHTODAY,NUM Q
32HL7SET ;
33 ; Entry point for AO's placed from CPRS/OERR
34 S FHTEXT=FHCOM,X1=STDT,X2=-1 D C^%DTC S STDT1=X
35 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
36 I '$D(FHRNUM) Q
37 S FILL="A;"_FHRNUM_";"_FHCOM_";"_FHORN
38 D SEND^FHWOR Q
39UPD100 ;Backdoor message to update file #100 with a new AO order
40 Q:'$$PATCH^XPDUTL("OR*3.0*215") ;must have CPRSv26 for O.M. backdoor
41 Q:'DFN K MSG D MSHOM^FHOMUTL ;Sets MSG(1), MSG(2) & MSG(3) for OM
42 S FILL="A;"_FHRNUM,FHODT=$P(FHRNUM,U,2),FHODT=$$FMTHL7^XLFDT(FHODT)
43 S MSG(4)="ORC|SN||"_FILL_"^FH||||^^^"_FHODT_"^"_FHODT_"||||||||"_FHTODAY
44 S MSG(5)="ODS|D||^^^FH-6^Additional Order^99OTH|"_FHTEXT
45 D EVSEND^FHWOR
46 Q
Note: See TracBrowser for help on using the repository browser.