source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGROHLR1.m@ 1185

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

initial load of FOIAVistA 6/30/08 version

File size: 5.8 KB
Line 
1DGROHLR1 ;GTS - ROM HL7 RECEIVE DRIVERS ; 2/18/05 12:19pm
2 ;;5.3;Registration;**572,622,647**;Aug 13, 1993
3 ;
4CONVFDA(DFN,DGDATA) ; LOOP THROUGH DATA TO FILE
5 N DFNC,F,IEN,FIELD,DGROAR,FNUM,QVAR,INX
6 ;
7 ;*DGROAR: Indirect reference to DGROAYi where "i" is the ORDER INDEX
8 ;* field value in 391.23. ORDER INDEX defines order for a group of
9 ;* fields loaded into the LST.
10 ;* DGROAYi defined for each group maintaining proper order.
11 ;* DG*5.3*572
12 ;
13 S DFNC=DFN_","
14 S INX=""
15 F S INX=$O(^DGRO(391.23,"D",INX)) Q:INX="" D
16 . S DGROAR="DGROAY"_INX
17 . S QVAR=0
18 . S F=""
19 . F S F=$O(@DGDATA@(F)) Q:F="" D
20 . . S IEN=""
21 . . F S IEN=$O(@DGDATA@(F,IEN)) Q:IEN="" D
22 . . . S FIELD=""
23 . . . F S FIELD=$O(@DGDATA@(F,IEN,FIELD)) Q:FIELD="" D
24 . . . . S ORDINX=$O(^DGRO(391.23,"E",F,FIELD,""))
25 . . . . D:(ORDINX=INX) SETARY
26 . . . . ;* Following line files Internal PEC, Rmv once Ext PEC is filed
27 . . . . I (ORDINX=INX)&(F=2) DO
28 . . . . .D:(FIELD=.361) FILEPEC
29 . . . . .D:((FIELD=.117)!(FIELD=.12111)!(FIELD=.14111)) FILECNTY
30 . . I (+$O(@DGROAR@(""))>0) S QVAR=1 D FILE
31 Q
32 ;
33FILECNTY ;*Retrieve county IEN and file county
34 ;*Retrieve State IEN corresponding to Temp, Conf, or Perm State
35 I (FIELD=.117),($D(^DPT(DFN,.11))) S STATEIEN=$P(^DPT(DFN,.11),"^",5)
36 I (FIELD=.12111),($D(^DPT(DFN,.121))) S STATEIEN=$P(^DPT(DFN,.121),"^",5)
37 I (FIELD=.14111),($D(^DPT(DFN,.141))) S STATEIEN=$P(^DPT(DFN,.141),"^",5)
38 ;
39 ;*Retrieve County IEN for exact county returned from LST
40 ; DG*647
41 I $G(STATEIEN)="" G NOCNTY
42 S DIC="^DIC(5,"_STATEIEN_",1,"
43 S DIC(0)="XS"
44 S X=@DGROAR@(F,DFNC,FIELD)
45 D ^DIC
46 S DGROCTY(F,DFNC,FIELD)=+Y
47 D FILE^DIE("","DGROCTY","ERR") ;File County IEN
48NOCNTY K @DGROAR@(F,DFNC,FIELD)
49 K STATEIEN,DGROCTY
50 Q
51 ;
52FILEPEC ;File Internal value of Prim Elig Code
53 ;Called from CONVFDA^DGROHLR1
54 ;Remove this call when fields required by PEC are received
55 ; from LST
56 I $D(@DGROAR@(F,DFNC,FIELD)) DO
57 . S DIC="^DIC(8,"
58 . S DIC(0)="MNSX"
59 . S X=@DGROAR@(F,DFNC,FIELD)
60 . D ^DIC
61 . S DGROPEC(F,DFNC,FIELD)=+Y
62 . D FILE^DIE("","DGROPEC","ERR")
63 . K @DGROAR@(F,DFNC,FIELD)
64 . K DGROPEC,DIC,X
65 Q
66 ;
67FILE ;*Execute FILE or UPDATE per FNUM (1st subscpt) for file # according
68 ;* to file/multiple record add or adding existing Patient data add
69 S FNUM=$O(@DGROAR@(""))
70 K %DT ;* Clean up leaks from Input transforms that set %DT(0)
71 ;
72 ;* Patient file processing
73 I +FNUM=2 DO
74 . D FILE^DIE("E","@DGROAR","ERR") ;*Add to existing Patient entry
75 ;
76 ;* Patient file multiples processing
77 I (+FNUM=2.01)!(+FNUM=2.141) DO
78 . D UPDATE^DIE("E","@DGROAR","","ERR")
79 I (+FNUM=2.02)!(+FNUM=2.06) DO
80 . N DGRODNUM,DGIEN,DNUMDATA,DGIEN2,DGROIEN
81 . S DGRODNUM=0
82 . F S DGRODNUM=$O(@DGROAR@(+FNUM,DGRODNUM)) Q:DGRODNUM="" D
83 . . S DGIEN=$P(DGRODNUM,",")
84 . . I DGIEN S DGIEN2=$P(DGIEN,"+",2)
85 . . S DNUMDATA=$G(@DGROAR@(+FNUM,DGRODNUM,.01))
86 . . I DGIEN2 S DGROIEN(DGIEN2)=DNUMDATA D
87 . . . D UPDATE^DIE("","@DGROAR","DGROIEN","ERR") ;*Converted Ext to Int
88 ;
89 ;* Processing fields [indicated in 391.23] not part of Patient file.
90 ;* Define IF section for each file not a Patient file field or
91 ;* Multiple.
92 I (+$P(FNUM,".")'=2) DO
93 . I +FNUM=38.1 DO
94 . . N DGROARBI
95 . . S DGROARBI(1)=DFN ;*Set 38.1 IEN to DFN
96 . . D UPDATE^DIE("E","@DGROAR","DGROARBI","ERR")
97 ;
98 K @DGROAR
99 Q
100 ;
101SETARY ;* Setup arrays of data to be filed
102 N U,D,DATA,NODE,NODE2,INENNUM
103 ;
104 I '$D(^DGRO(391.23,"C",F,FIELD)) Q
105 ;
106 S U="^"
107 ;
108 ;CHECK LOCAL PATIENT FILE FOR EXISTING DATA, DO NOT OVERWRITE
109 S D=$$GET1^DIQ(F,DFNC,FIELD)
110 I D'="" K @DGDATA@(F,IEN,FIELD) Q
111 ;
112 S DATA=$G(@DGDATA@(F,IEN,FIELD,"E"))
113 Q:DATA=""
114 ;
115 ;* Design of this Subroutine:
116 ;* Set array defining groups of date for Fileman filing in
117 ;* a predefined order.
118 ;* Indirection defined various array names for different ordered
119 ;* data groups in CONVFDA.
120 ;* File Ext. values returned from LST per ORDER INDEX.
121 ;* DG*5.3*572
122 ;
123 ;* Get field entry IEN in ROM 391.23 file
124 S INENNUM=INX
125 ;
126 I F=2 DO Q
127 . S @DGROAR@(F,DFNC,FIELD)=DATA ;*Indirection to Patient Array
128 . K @DGDATA@(F,IEN,FIELD)
129 ;
130 ;* Set array for all other files (not Patient or Security files)
131 ;* This section is for new entries in files. Not for Multiples.
132 ;* Code to process specific files needed in CONVFDA
133 I (+$P(F,".")'=2),(F'=38.1) DO Q
134 . S @DGROAR@(F,"+1,",FIELD)=DATA
135 . K @DGDATA@(F,IEN,FIELD)
136 ;
137 ;SET ALIAS AND CONFIDENTIAL ADDRESS CAT. SUBFILE ARRAYS
138 I (F=2.01)!(F=2.141) D Q
139 . S NODE2="+"
140 . S NODE2=NODE2_$P(IEN,",")_","_DFNC
141 . S @DGROAR@(F,NODE2,FIELD)=DATA ;*Indirection to Patient Array
142 . K @DGDATA@(F,IEN,FIELD)
143 ;
144 ;SET RACE AND ETHNICITY ARRAYS
145 I (F=2.02)!(F=2.06) D Q
146 . N REFILE,REIEN,DATA30,QFL,DATACOMP,TEST,ERR,INACTIVE
147 . I (F=2.02),(FIELD=.01) S REFILE=10
148 . I (F=2.06),(FIELD=.01) S REFILE=10.2
149 . I FIELD=.02 S REFILE=10.3
150 . S DATA30=$E(DATA,1,30) D
151 . . S QFL=0,REIEN="",NODE=""
152 . . D FIND^DIC(REFILE,"","@;.01;200","",DATA30,,"B","","","TEST","ERR")
153 . . F S NODE=$O(TEST("DILIST",2,NODE)) Q:'NODE D Q:$G(QFL)=1
154 . . . S REIEN=$G(TEST("DILIST",2,NODE))
155 . . . S INACTIVE=$G(TEST("DILIST","ID",NODE,200))
156 . . . Q:INACTIVE="YES" ;* QUIT if Race or Eth Inact
157 . . . S DATACOMP=$G(TEST("DILIST","ID",NODE,.01))
158 . . . I DATACOMP=DATA S QFL=1
159 . Q:'QFL
160 . Q:$G(INACTIVE)="YES" ;* No entry for Inactive Race/Ethncty
161 . S DATA=REIEN ;*Race/Ethncty/MOC (10/10.2/10.3) IEN for data recvd
162 . ;
163 . S NODE2="+" ;*+ for all fields, All fields added in one UPDATE
164 . S NODE2=NODE2_$P(IEN,",")_","_DFNC ;*No + for DFNC, DPT record exists
165 . S @DGROAR@(F,NODE2,FIELD)=DATA ;*Indirection to Patient Array
166 . K @DGDATA@(F,IEN,FIELD)
167 ;
168 ;* Set all sensitive fields (38.1) in array
169 I F=38.1 D Q
170 . Q:('$D(@DGDATA@(F))) ;*Data already filed
171 . S FIELD=.01
172 . S @DGROAR@(F,"+1,",FIELD)=$$GET1^DIQ(2,DFN,.01)
173 . F S FIELD=$O(@DGDATA@(F,IEN,FIELD)) Q:'FIELD D
174 . . S @DGROAR@(F,"+1,",FIELD)=@DGDATA@(F,IEN,FIELD,"E")
175 . K @DGDATA@(F,IEN)
176 . S FIELD=999999 ;*Skip to end of 38.1 field list in @DGDATA
177 Q
Note: See TracBrowser for help on using the repository browser.