source: FOIAVistA/trunk/r/CLINICAL_CASE_REGISTRIES-ROR/RORHL15.m@ 1203

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

initial load of FOIAVistA 6/30/08 version
File size: 4.8 KB
Line 
1RORHL15 ;HOIFO/BH - HL7 IV DATA: OBR, OBX ; 5/30/06 9:40am
2 ;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
3 ;
4 ; This routine uses the following IAs:
5 ;
6 ; #2400 OCL^PSOORRL and OEL^PSOORRL (controlled)
7 ; #4549 ZERO^PSS52P6 (supported)
8 ; #4550 ZERO^PSS52P7 (supported)
9 ; #4826 PSS436^PSS55 (supported)
10 ;
11 Q
12 ;
13 ;***** SEARCHES FOR IV DATA
14 ;
15 ; RORDFN IEN of the patient in the PATIENT file (#2)
16 ;
17 ; .DXDTS Reference to a local variable where the
18 ; data extraction time frames are stored.
19 ;
20 ; Return Values:
21 ; <0 Error code
22 ; 0 Ok
23 ; >0 Non-fatal error(s)
24 ;
25 ; The ^TMP("PS",$J) global node is used by this function.
26 ;
27EN1(RORDFN,DXDTS) ;
28 N ERRCNT,IDX,IEN55,II,NODE,RC,ROR55,ROR55SUB,RORENDT,RORII,RORORD,RORSTDT,RORTMP
29 S (ERRCNT,RC)=0
30 ;
31 S RORTMP=$$ALLOC^RORTMP()
32 S ROR55=$$ALLOC^RORTMP(.ROR55SUB)
33 ;
34 S IDX=0
35 F S IDX=$O(DXDTS(14,IDX)) Q:IDX'>0 D Q:RC<0
36 . S RORSTDT=$P(DXDTS(14,IDX),U),RORENDT=$P(DXDTS(14,IDX),U,2)
37 . ;--- Load the list of prescriptions
38 . K ^TMP("PS",$J),@RORTMP
39 . D OCL^PSOORRL(RORDFN,RORSTDT,RORENDT)
40 . Q:$D(^TMP("PS",$J))<10
41 . ;
42 . ;--- Select the prescriptions
43 . S RORII=0
44 . F S RORII=$O(^TMP("PS",$J,RORII)) Q:'RORII D
45 . . S RORORD=$P(^TMP("PS",$J,RORII,0),U)
46 . . Q:RORORD'>0
47 . . S II=$P(RORORD,";"),II=$E(II,$L(II))
48 . . Q:II'="V"
49 . . ;---
50 . . M @RORTMP@(RORII)=^TMP("PS",$J,RORII)
51 . ;
52 . ;--- Browse through the list and generate the HL7 segments
53 . S RORII=0
54 . F S RORII=$O(@RORTMP@(RORII)) Q:'RORII D
55 . . S RORORD=$P(@RORTMP@(RORII,0),U),IEN55=+$P(RORORD,";")
56 . . D PSS436^PSS55(RORDFN,IEN55,ROR55SUB)
57 . . S NODE=$NA(@ROR55@(IEN55))
58 . . ;---
59 . . S TMP=$$OBR(NODE,RORDFN)
60 . . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
61 . . ;---
62 . . S TMP=$$OBX(NODE,RORDFN)
63 . . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
64 ;
65 D FREE^RORTMP(ROR55),FREE^RORTMP(RORTMP)
66 K ^TMP("PS",$J)
67 Q $S(RC<0:RC,1:ERRCNT)
68 ;
69 ;***** IV OBR SEGMENT BUILDER
70 ;
71 ; NODE Closed root of a subtree that stores the output of
72 ; the PSS436^PSS55 Pharmacy API
73 ;
74 ; RORDFN IEN of the patient in the PATIENT file (#2)
75 ;
76 ; Return Values:
77 ; <0 Error code
78 ; 0 Ok
79 ; >0 Non-fatal error(s)
80 ;
81OBR(NODE,RORDFN) ;
82 N CS,ERRCNT,IEN,RC,RORMSG,RORSEG,TMP
83 S (ERRCNT,RC)=0
84 D ECH^RORHL7(.CS)
85 ;
86 ;--- Initialize the segment
87 S RORSEG(0)="OBR"
88 ;
89 ;--- OBR-3 - Order Number
90 S RORSEG(3)=$P($G(@NODE@(.01)),U)
91 ;
92 ;--- OBR-4 - IV CPT Code
93 S RORSEG(4)="90780"_CS_"IV"_CS_"C4"
94 ;
95 ;--- OBR-7 - Start Date
96 S TMP=$$FMTHL7^XLFDT($P($G(@NODE@(.02)),U))
97 Q:TMP'>0 $$ERROR^RORERR(-100,,,RORDFN,"No start date","PSS436^PSS55")
98 S RORSEG(7)=TMP
99 ;
100 ;--- OBR-8 - Stop Date
101 S RORSEG(8)=$$FM2HL^RORHL7($P($G(@NODE@(.03)),U))
102 ;
103 ;--- OBR-13 - Schedule
104 S RORSEG(13)=$$ESCAPE^RORHL7($P($G(@NODE@(.09)),U))
105 ;
106 ;--- OBR-20 - Infusion Rate
107 S RORSEG(20)=$$ESCAPE^RORHL7($P($G(@NODE@(.08)),U))
108 ;
109 ;--- OBR-24 - Diagnostic Service ID
110 S RORSEG(24)="IMM"
111 ;
112 ;--- OBR-40 - Type
113 S TMP=$P($G(@NODE@(.04)),U)
114 I TMP'="" D S RORSEG(40)=TMP
115 . S $P(TMP,CS,2)=$P($G(@NODE@(.04)),U,2)
116 . S $P(TMP,CS,3)="VA"
117 ;
118 ;--- OBR-44 - Division
119 S IEN=+$P($G(@NODE@(9)),U)
120 I IEN>0 D
121 . S IEN=+$$GET1^DIQ(42,IEN_",",44,"I",,"RORMSG")
122 . D:$G(DIERR) DBS^RORERR("RORMSG",-99,,,42,IEN_",")
123 S RORSEG(44)=$$DIV44^RORHLUT1(IEN,CS)
124 ;
125 ;--- Store the segment
126 D ADDSEG^RORHL7(.RORSEG)
127 Q ERRCNT
128 ;
129 ;***** IV OBX SEGMENT(S) BUILDER
130 ;
131 ; NODE Closed root of a subtree that stores the output of
132 ; the PSS436^PSS55 Pharmacy API
133 ;
134 ; RORDFN IEN of the patient in the PATIENT file (#2)
135 ;
136 ; Return Values:
137 ; <0 Error code
138 ; 0 Ok
139 ; >0 Non-fatal error(s)
140 ;
141OBX(NODE,RORDFN) ;
142 N ADD,CS,ERRCNT,I,ID,RC,SOL,TMP
143 S (ERRCNT,RC)=0
144 D ECH^RORHL7(.CS)
145 ;
146 ;=== Other print info
147 S TMP=$P($G(@NODE@(31)),U)
148 D:TMP'="" SETOBX(TMP,"OTPR"_CS_"Other Print info."_CS_"VA080")
149 ;
150 ;=== Additive data
151 I $G(@NODE@("ADD",0))>0 D
152 . S ID="ADD"_CS_"Additive"_CS_"VA080"
153 . S I=0
154 . F S I=$O(@NODE@("ADD",I)) Q:I'>0 D
155 . . S ADD=$P($G(@NODE@("ADD",I,.01)),U,2)
156 . . D:ADD'="" SETOBX(ADD,ID,$P($G(@NODE@("ADD",I,.02)),U))
157 ;
158 ;=== Solution Data
159 I $G(@NODE@("SOL",0))>0 D
160 . S ID="SOL"_CS_"Solution"_CS_"VA080"
161 . S I=0
162 . F S I=$O(@NODE@("SOL",I)) Q:I'>0 D
163 . . S SOL=$P($G(@NODE@("SOL",I,.01)),U,2)
164 . . D:SOL'="" SETOBX(SOL,ID,$P($G(@NODE@("SOL",I,1)),U))
165 ;
166 Q ERRCNT
167 ;
168 ;***** CREATES AND STORES THE OBX SEGMENT
169SETOBX(OBX5,OBX3,OBX7) ;
170 N RORSEG
171 ;--- Initialize the segment
172 S RORSEG(0)="OBX"
173 ;--- OBX-2 - Value Type
174 S RORSEG(2)="FT"
175 ;--- OBX-3 - Obervation Identifier
176 S RORSEG(3)=OBX3
177 ;--- OBX-5 - Observation Value
178 S RORSEG(5)=$$ESCAPE^RORHL7(OBX5)
179 ;--- OBX-7 - Strength (additives) or volume (solutions)
180 S:$G(OBX7)'="" RORSEG(7)=OBX7
181 ;--- OBX-11 - Observation Result Status
182 S RORSEG(11)="F"
183 ;--- Store the segment
184 D ADDSEG^RORHL7(.RORSEG)
185 Q
Note: See TracBrowser for help on using the repository browser.