source: FOIAVistA/tag/r/DIETETICS-FH/FHWOR.m@ 1251

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

initial load of FOIAVistA 6/30/08 version

File size: 5.6 KB
Line 
1FHWOR ; HISC/NCA - Main Routine to Decode HL7 ;10/10/00 14:55
2 ;;5.5;DIETETICS;**2,5**;Jan 28, 2005;Build 53
3EN(MSG) ; Entry Point for OE/RR 3 and pass MSG in FHMSG
4 N ACT,ADM,BID,COM,FHDFN,DFN,EDT,FHPV,FHMSG,FHWF,NOW,SDT,CHK,DA,DATA,DATE,DIET,DUR,FHC,FHD,FHD1,FHD2,FOR,FTYP,IEN,ITVL,LP,MEAL,NAM,PER,PID,SERV,TIM,TIME,TM,TXT,TYPC,WARD,X,XX,YR
5 S TXT="",FHWF=2 ; FHWF=2 - Orders from OE/RR
6 F L=0:0 S L=$O(MSG(L)) Q:L<1 S FHMSG(L)=$G(MSG(L))
7 Q:'$D(FHMSG)
8 ; Decode MSH
9 S X=$G(FHMSG(1)) I $E(X,1,3)'="MSH" S TXT="MSH not first record" D GETOR G ERR
10 ; Check PID
11 S X=$G(FHMSG(2)) I $E(X,1,3)'="PID" S TXT="PID not second record" D GETOR G ERR
12 S NAM=$P(X,"|",6),DFN=$P(X,"|",4)
13 I '$D(^DPT("B",$E(NAM,1,30),DFN)) S TXT="Name/DFN not found" D GETOR G ERR
14 S FHZ115="P"_DFN D ADD^FHOMDPA I FHDFN="" S TXT="Patient not found in File #115" D GETOR G ERR
15 D PID^VADPT6 S PID=$G(VA("PID")),BID=$G(VA("BID")) K VA
16 S X=$G(FHMSG(3)) I $E(X,1,5)="ORC|Z" G PURGE
17 I $E(X,1,6)="ORC|DE" Q ;6/2005 quit processing if "DE" returned
18 ;Check for outpatient orders
19 I $P(X,"|",3)="O" D ^FHOMWOR Q
20 S WARD=$G(^DPT(DFN,.1)) I WARD="" D CHK^FHWORR G:CHK CANCEL S:'CHK TXT="Not an inpatient" D GETOR G ERR
21 S ADM=$G(^DPT("CN",WARD,DFN)) I ADM<1 S TXT="Admission not found" D GETOR G ERR
22 I '$D(^FHPT(FHDFN,"A",ADM,0)) I '$D(^DGPM(ADM,0)) S TXT="Admission not found" D GETOR G ERR
23 I '$D(^FHPT(FHDFN,"A",ADM,0)) S DA=DFN D ^FHWADM
24 ; Check PV1
25 S X=$G(FHMSG(3)) G:$E(X,1,3)="ORC" CANCEL I $E(X,1,3)'="PV1" S TXT="Third message not ORC or PV1" D GETOR G ERR
26 ; Decode ORC
27 S X=$G(FHMSG(4)) I $E(X,1,3)'="ORC" S TXT="Message 4 not ORC as expected" D GETOR G ERR
28 S ACT=$P(X,"|",2) I ACT'="NW" S TXT="Action not NW as expected" D GETOR G ERR
29 S FHORN=$P(X,"|",3),DUR=$P(X,"|",8)
30 S ITVL=$P(DUR,"^",2),SDT=$P(DUR,"^",4),EDT=$P(DUR,"^",5)
31 S FHPV=$P(X,"|",13),NOW=$P(X,"|",16) I NOW="" S TXT="No Effective Date" G ERR
32 S X=$G(FHMSG(5)) I $E(X,1,3)="ODT" D ^FHWOR3 G KIL
33 I $E(X,1,3)="OBR" D ^FHWOR61 G KIL
34 I $E(X,1,3)'="ODS" S TXT="Message 5 not ODT or ODS as expected" G ERR
35 S TYPC=$P(X,"|",2) I TYPC="ZE" D ^FHWOR5 G KIL
36 S DIET=$P(X,"|",4),DIET=$E(DIET,4,$L(DIET)),COM=$P(X,"|",5)
37 I $E(DIET,1,4)="FH-5" D ^FHWOR4 G KIL
38 I $E(DIET,1,4)="FH-6" D ^FHWOR1 G KIL
39 D ^FHWOR2 G KIL
40CANCEL ; Cancel/Discontinue
41 S DATA=X,FOR=0
42 S ACT=$P(DATA,"|",2)
43 S FHORN=$P(DATA,"|",3),FILL=$P(DATA,"|",4),FTYP=$P(FILL,";",1)
44 I ACT'="CA",ACT'="DC",ACT'="NA",ACT'="DE",ACT'="SS" S TXT="Action not CA, DC, NA, or DE as expected" G CERR
45 I FTYP="R"!(FTYP="S") D OMSTAT^FHWORR Q ;Status update for outpt meals
46 I "ADEINT"'[FTYP G CSEND:ACT="CA"!(ACT="DC"),KIL
47 S FOR=$S(FTYP="A":1,FTYP="D":2,FTYP="E":3,FTYP="N":4,FTYP="T":5,FTYP="I":6,1:0)
48 I 'FOR G CSEND:ACT="CA"!(ACT="DC"),KIL
49 I ACT="SS" G STATUS^FHWORR
50 I ACT="NA" D NA K ACT,TXT K MSG Q
51 I ACT="DE" K MSG G KIL
52CAN ; Cancel Order From OE
53 I FOR=1 D CAN^FHWOR1 G KIL
54 I FOR=2 D CAN^FHWOR2 G KIL
55 I FOR=3 D CAN^FHWOR3 G KIL
56 I FOR=4 D CAN^FHWOR4 G KIL
57 I FOR=5 D CAN^FHWOR5 G KIL
58 I FOR=6 D CAN^FHWOR61 G KIL
59 G KIL
60PURGE ; Purge OE/RR Orders
61 I $E(X,5,6)'="Z@" G KIL
62 S FHORN=+$P(X,"|",3),FILL=$P(X,"|",4),FTYP=$P(FILL,";",1)
63 S FHDR=+$P(FILL,";",3),ADM=+$P(FILL,";",2)
64 I FTYP="A" S:$P($G(^FHPT(FHDFN,"A",ADM,"OO",FHDR,0)),"^",8)=FHORN $P(^FHPT(FHDFN,"A",ADM,"OO",FHDR,0),"^",8)=""
65 I FTYP="D" S:$P($G(^FHPT(FHDFN,"A",ADM,"DI",FHDR,0)),"^",14)=FHORN $P(^FHPT(FHDFN,"A",ADM,"DI",FHDR,0),"^",14)=""
66 I FTYP="E" S SDT=$P(FILL,";",4),EDT=$P(FILL,";",5) S:EDT<SDT EDT=SDT D
67 .F EL=SDT\1:0 S EL=$O(^FHPT(FHDFN,"A",ADM,"EL",EL)) Q:EL<1!(EL>EDT) D
68 ..S:$P($G(^FHPT(FHDFN,"A",ADM,"EL",EL,0)),"^",7)=FHORN $P(^FHPT(FHDFN,"A",ADM,"EL",EL,0),"^",7)=""
69 ..Q
70 .Q
71 I FTYP="N" S:$P($G(^FHPT(FHDFN,"A",ADM,"DI",FHDR,0)),"^",14)=FHORN $P(^FHPT(FHDFN,"A",ADM,"DI",FHDR,0),"^",14)=""
72 I FTYP="T" S:$P($G(^FHPT(FHDFN,"A",ADM,"TF",FHDR,0)),"^",14)=FHORN $P(^FHPT(FHDFN,"A",ADM,"TF",FHDR,0),"^",14)=""
73 I FTYP="I" S:$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",13)=FHORN $P(^FHPT(FHDFN,"A",ADM,0),"^",13)=""
74 K EL,FHDR
75 S $P(MSG(1),"|",9)="ORR",$P(MSG(3),"|",2)="ZR",$P(MSG(1),"|",3)="DIETETICS" G EVSEND
76NA ; Number Assign
77 I FOR=1 D NA^FHWOR1 G KIL
78 I FOR=2 D NA^FHWOR2 G KIL
79 I FOR=3 D NA^FHWOR3 G KIL
80 I FOR=4 D NA^FHWOR4 G KIL
81 I FOR=5 D NA^FHWOR5 G KIL
82 I FOR=6 D NA^FHWOR61 G KIL
83 Q
84CVT ; Convert HL7 date to FM date
85 Q:DATE="" S DATE=$$HL7TFM^XLFDT(DATE)
86 I $P(DATE,".",2)=24 S DATE=$$FMADD^XLFDT(DATE,0,0,1)
87 Q
88ERR ; Send error MSG
89 K MSG D RMSH
90 S $P(MSG(3),"|",1,2)="ORC"_"|"_$S($P($G(MSG(3)),"|",1)="ORC":"U"_$E($P($G(MSG(3)),"|",2),1),1:"OC"),$P(MSG(3),"|",3)=FHORN
91 S $P(MSG(3),"|",4)=$S($P(FHMSG(3),"|",1)="ORC":$P(FHMSG(3),"|",4),1:"")
92 S $P(MSG(3),"|",13)=$S($P(FHMSG(3),"|",1)="ORC":$P(FHMSG(3),"|",13),1:$P(FHMSG(4),"|",13))
93 S $P(MSG(3),"|",16)=$S($P(FHMSG(3),"|",1)="ORC":$P(FHMSG(3),"|",16),1:$P(FHMSG(4),"|",16))
94 S $P(MSG(3),"|",17)=TXT G EVSEND
95SEND ; Send OK MSG to OERR
96 K MSG D RMSH
97 S MSG(3)="ORC|OK|"_FHORN_"|"_FILL_"^"_"FH" G EVSEND
98CERR ; Send unable MSG
99 K MSG D RMSH
100 S MSG(3)="ORC|U"_$E(ACT,1)_"|"_FHORN_"|"_FILL_"|||||||||||||"_TXT G EVSEND
101CSEND ; Send Canceled/Discontinued MSG to OERR
102 K MSG D RMSH
103 S MSG(3)="ORC|"_$E(ACT,1)_"R"_"|"_FHORN_"|"_FILL
104EVSEND ; Send Message to OE/RR
105 K ACT,FILL,FHORN,SITE,TXT D MSG^XQOR("FH EVSEND OR",.MSG) K MSG Q
106MSH ; Code MSH message
107 D MSH^FHWORR
108 Q
109RMSH ; Code MSH Return Message
110 D SITE^FH
111 S MSG(1)="MSH|^~\&|DIETETICS|"_SITE(1)_"|||||ORR"
112 ; code PID
113 S MSG(2)="PID|||"_DFN_"||"_$P($G(^DPT(DFN,0)),"^",1)
114 Q
115GETOR ; Call to Get FHORN
116 D GETOR^FHWORR Q
117KIL ; Kill Variables
118 K ACT,ADM,BID,COM,FHDFN,DFN,EDT,FHPV,FHMSG,FHWF,NOW,SDT,CHK,DA,DATA,DATE,DIET,DUR,FHC,FHD,FHD1,FHD2,FOR,FTYP,IEN,ITVL,LP,MEAL,NAM,PER,PID,SERV,TIM,TIME,TM,TXT,TYPC,WARD,X,XX,YR Q
Note: See TracBrowser for help on using the repository browser.