source: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXSCX1.m@ 636

Last change on this file since 636 was 636, checked in by George Lilly, 14 years ago

WorldVistAEHR overlayed on FOIAVistA
File size: 8.9 KB
Line 
1ECXSCX1 ;ALB/JAP,BIR/DMA-Clinic Extract Message ; 8/17/06 7:59am
2 ;;3.0;DSS EXTRACTS;**8,28,24,27,29,30,31,33,84,92**;Dec 22, 1997;Build 30
3EN ;entry point from ecxscx
4 N ECX
5 ;send missing clinic message
6 S ECX=$O(^TMP($J,"ECXS","MISS",0)) D
7 .Q:ECX=""
8 .S XMSUB="MISSING CLINICS in File #728.44",XMDUZ="DSS SYSTEM"
9 .K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))=""
10 .F ECX=1:1:5 S ^TMP($J,"ECXS","MISS",ECX,0)=$P($T(MSG+ECX),";;",2)
11 .S XMTEXT="^TMP($J,""ECXS"",""MISS""," D ^XMD
12 ;send no division message
13 S ECX=$O(^TMP($J,"ECXS","DIV",0)) D
14 .Q:ECX=""
15 .S XMSUB="CLINICS w/o DIVISION Data",XMDUZ="DSS SYSTEM"
16 .K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))=""
17 .F ECX=1:1:5 S ^TMP($J,"ECXS","DIV",ECX,0)=$P($T(MSG2+ECX),";;",2)
18 .S XMTEXT="^TMP($J,""ECXS"",""DIV""," D ^XMD
19 ;cleanup
20 K ^TMP($J,"ECXS")
21 Q
22MSG ;text for missing clinic
23 ;;The following clinics have not been entered into the CLINIC AND
24 ;;STOP CODES file (#728.44). If any listed clinic is currently
25 ;;active, please use the options 'Create DSS Clinic Stop Code File'
26 ;;and 'Enter/Edit DSS Stop Codes for Clinics' to update this file.
27 ;;
28 ;
29MSG2 ;text for missing division
30 ;;The following clinics in the HOSPITAL LOCATION file (#44) have not
31 ;;been assigned to a division from the MEDICAL CENTER DIVISION file
32 ;;(#40.8). CLI extract records associated with these clinics have
33 ;;been given a default Division identifier of "1".
34 ;;
35 ;
36MISS ;load ^tmp if clinic missing from #728.44
37 N DAT,ID,RD
38 S (ID,RD)=""
39 S DAT=$G(^SC(SC,"I")) I DAT]"" S ID=+DAT,RD=$P(DAT,U,2)
40 ;ignore inactive clinics
41 I ID,ID<DT I 'RD!(RD>DT) Q
42 I '$D(^TMP($J,"ECXS","ECXMISS")) S ^TMP($J,"ECXS","ECXMISS")=10
43 S ECXMISS=^TMP($J,"ECXS","ECXMISS")
44 S ^TMP($J,"ECXS","MISS",ECXMISS,0)=$J(SC,6)_" "_$$LJ^XLFSTR($P(^SC(SC,0),U),40)_ECSC_"/"_ECCSC
45 S ^TMP($J,"ECXS","ECXMISS")=ECXMISS+1
46 Q
47 ;
48NODIV ;load ^tmp if clinic w/o division
49 N DAT,ID,RD
50 S (ID,RD)=""
51 S DAT=$G(^SC(SC,"I")) I DAT]"" S ID=+DAT,RD=$P(DAT,U,2)
52 ;ignore inactive clinics
53 I ID,ID<DT I 'RD!(RD>DT) Q
54 I '$D(^TMP($J,"ECXS","ECXMISS")) S ^TMP($J,"ECXS","ECXMISS")=10
55 S ECXMISS=^TMP($J,"ECXS","ECXMISS")
56 S ^TMP($J,"ECXS","DIV",ECXMISS,0)=$J(SC,6)_" "_$$LJ^XLFSTR($P(^SC(SC,0),U),40)
57 S ^TMP($J,"ECXS","ECXMISS")=ECXMISS+1
58 Q
59 ;
60FEEDER(ECXSC,ECXSD,ECXP1,ECXP2,ECXP3,ECXSEND,ECXDIV) ;get transmission style and feeder key variables
61 ;feeder key = primary stop code_secondary stop code_length of appointment_national clinic code_noshow indicator
62 ; input
63 ; ECXSC = ien of clinic in file #44 (required)
64 ; ECXSD = start date of extract date range (required)
65 ; ECXP1,ECXP2,ECXP3,ECXSEND passed by reference (required)
66 ; output (passed-by-reference variables)
67 ; ECXP1 = primary stop code
68 ; ECXP2 = secondary stop code
69 ; ECXP3 = field #7 of file #728.44
70 ; ECXSEND = field #5 of file #728.44
71 ; ECXDIV = field #3.5 of file #44
72 N ECSC,ECCSC,ECSD1,ECXNC,ECXMISS,CLIN,SC
73 S (ECXP1,ECXP2)="000",ECXP3="0000"
74 S ECXSEND=1,ECXDIV=0
75 Q:+ECXSC=0
76 ;get needed data from ^tmp
77 I $D(^TMP($J,"ECXS","SC",ECXSC)) D
78 .S CLIN=^TMP($J,"ECXS","SC",ECXSC)
79 .S ECXP1=$P(CLIN,U),ECXP2=$P(CLIN,U,2),ECXP3=$P(CLIN,U,3),ECXSEND=$P(CLIN,U,4),ECXDIV=$P(CLIN,U,5)
80 .S ECXDIV=+$P($G(^TMP($J,"ECXCL",ECXSC)),U,4) S:ECXDIV=0 ECXDIV=1
81 ;otherwise, set needed data in ^tmp
82 I '$D(^TMP($J,"ECXS","SC",ECXSC)) D
83 .;get division or send no division msg
84 .S ECXDIV=+$P($G(^TMP($J,"ECXCL",ECXSC)),U,4)
85 .I ECXDIV=0 S SC=ECXSC D NODIV S ECXDIV=1
86 .;get other data from file #44 if no #727.44 record; send missing clinic msg
87 .I '$D(^ECX(728.44,ECXSC,0)) D
88 ..S ECSC=+$P($G(^SC(ECXSC,0)),U,7),ECCSC=+$P(^(0),U,18)
89 ..S SC=ECXSC,ECSD1=ECXSD D MISS
90 ..S:ECSC ECXP1=$P($G(^DIC(40.7,ECSC,0)),U,2),ECXP1=$$RJ^XLFSTR(+ECXP1,3,0)
91 .;otherwise get other data from file #728.44
92 .S EC=$G(^ECX(728.44,ECXSC,0)) D
93 ..Q:EC=""
94 ..S ECXSEND=$P(EC,U,6)
95 ..Q:ECXSEND=6
96 ..S ECSC=+$P(EC,U,4),ECCSC=+$P(EC,U,5)
97 ..I 'ECSC S ECSC=+$P(EC,U,2),ECCSC=+$P(EC,U,3)
98 ..I ECSC S ECXP1=$$RJ^XLFSTR(ECSC,3,0),ECXP2=$$RJ^XLFSTR(ECCSC,3,0)
99 ..;if primary stop not valid, use file #44 record
100 ..I 'ECSC S ECSC=+$P($G(^SC(ECXSC,0)),U,7),ECCSC=+$P($G(^(0)),U,18) I ECSC D
101 ...S ECXP1=+$P($G(^DIC(40.7,ECSC,0)),U,2)
102 ...S:ECCSC ECXP2=+$P($G(^DIC(40.7,ECCSC,0)),U,2)
103 ...S ECXP1=$$RJ^XLFSTR(ECXP1,3,0),ECXP2=$$RJ^XLFSTR(ECXP2,3,0)
104 .;for action code=1, secondary stop code is always "000"
105 .I ECXSEND=1 S ECXP2="000"
106 .;action code of 2 or 3 should not be used, but continue to follow v2t11 logic
107 .I ECXSEND=2 S ECXP1=ECXP2,ECXP2="000"
108 .;for action code=4, need to get national clinic code
109 .I ECXSEND=4 D
110 ..S ECXNC=+$P($G(^ECX(728.44,ECXSC,0)),U,8)
111 ..I ECXNC S ECXNC=$P($G(^ECX(728.441,ECXNC,0)),U),ECXP3=$$RJ^XLFSTR(ECXNC,4,0)
112 .;set data in ^tmp
113 .S ^TMP($J,"ECXS","SC",ECXSC)=ECXP1_U_ECXP2_U_ECXP3_U_ECXSEND
114 Q
115 ;
116VISIT(ECXDFN,ECXVISIT,ECXVIST,ECXERR) ;get visit specific data
117 ;input ECXVISIT = pointer to file #9000010
118 ; ECXSVC = sc percentage
119 ;output ECXVSIT = data array
120 ; ECXERR = 1 indicates error; otherwise, 0
121 N AO,ARRAY,CM,CNT,CPT,DA,DATE,DA,DIQ,ICD,ICD9,IR,LEN,M,MOD,MST,NUM
122 N PROV,PROVPC,REC,VAL,VISIT,X,Y,PGE
123 S ECXERR=0,VISIT=ECXVISIT
124 S (ECXVIST("AO"),ECXVIST("IR"),ECXVIST("PGE"),ECXVIST("HNC"))=""
125 S (ECXVIST("MST"),ECXVIST("PROV"),ECXVIST("PROV CLASS"))=""
126 S (ECXVIST("PROV NPI"),ECXVIST("SOURCE"))=""
127 F I="P",1,2,3,4 S ECXVIST("ICD9"_I)=""
128 F I=1:1:8 S ECXVIST("CPT"_I)=""
129 D ENCEVENT^PXAPI(VISIT)
130 I $O(^TMP("PXKENC",$J,VISIT,""))']"" K ECXVIST S ECXERR=1
131 Q:ECXERR
132 S DATE=$P($P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0),U,1),".",1)
133 S ECXVIST("SOURCE")=$P($G(^TMP("PXKENC",$J,VISIT,"VST",VISIT,812)),U,3)
134 ;get icd9 codes upto 5; else use 799.9
135 K ARY S ICD("P")=0,ICD("S")=0,(ARY,REC)=""
136 F S REC=$O(^TMP("PXKENC",$J,VISIT,"POV",REC)) Q:REC="" D
137 .S VAL=^TMP("PXKENC",$J,VISIT,"POV",REC,0) Q:'VAL
138 .I $P(VAL,U,12)="P" D
139 ..S:'$D(ARY("P",+VAL)) CNT=ICD("P")+1,ICD("P",CNT)=+VAL,ICD("P")=CNT
140 ..S ARY("P",+VAL)=""
141 .I $P(VAL,U,12)'="P" D
142 ..S:'$D(ARY("S",+VAL)) CNT=ICD("S")+1,ICD("S",CNT)=+VAL,ICD("S")=CNT
143 ..S ARY("S",+VAL)=""
144 S CNT=0,ECXVIST("ICD9P")=$P($G(^ICD9(+$G(ICD("P",1),0),0)),U)
145 F I=2:1 Q:'$D(ICD("P",I)) D Q:CNT>4
146 .S CNT=CNT+1,ECXVIST("ICD9"_CNT)=$P($G(^ICD9(ICD("P",I),0)),U)
147 I CNT<4 F I=1:1:8 Q:'$D(ICD("S",I)) D Q:CNT>4
148 .I '$D(ARY("P",ICD("S",I))) D
149 ..S CNT=CNT+1,ECXVIST("ICD9"_CNT)=$P($G(^ICD9(ICD("S",I),0)),U)
150 S:(ECXVIST("ICD9P")="")&(ECXVIST("ICD91")="") ECXVIST("ICD9P")="799.9"
151 ;get first provider designated as primary
152 ;if no primary, then get first physician provider
153 ;if no physician, then get first provider
154 S (PROV,PROVPC)=""
155 I $O(^TMP("PXKENC",$J,VISIT,"PRV",0)) D
156 .S (REC,VAL)=0 D
157 ..F S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",REC)) Q:('REC)!(VAL) D
158 ...S:($P(^(REC,0),U,4)="P") VAL=+^(0)
159 ...S PROV=VAL,PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE)
160 .I 'VAL S (REC,VAL)=0 D
161 ..F S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",REC)) Q:('REC)!(VAL) D
162 ...S (PROV,VAL)=+^(REC,0)
163 ...S PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE) Q:PROVPC=""
164 ...S NUM=$E(PROVPC,2,7) S:(NUM<110000)!(NUM>119999) VAL=0,PROVPC=""
165 .I 'VAL D
166 ..S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",0)) Q:('REC)!(VAL)
167 ..S VAL=+^(REC,0),PROV=VAL,PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE)
168 .S:PROV]"" PROV="2"_PROV
169 S ECXVIST("PROV")=PROV,ECXVIST("PROV CLASS")=PROVPC
170 S ECXVIST("PROV NPI")=""
171 ;get cpt codes upto 8 & modifiers upto 5
172 S CNT=1,PROV=$E(PROV,2,99)
173 D:$O(^TMP("PXKENC",$J,VISIT,"CPT",0))
174 .S REC=0 D:PROV]""
175 ..F S REC=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC)) Q:'REC D Q:CNT>8
176 ...S CPT="",NODE=$G(^TMP("PXKENC",$J,VISIT,"CPT",REC,12))
177 ...Q:NODE=""
178 ...S NOD1=$S($P(NODE,U,4)=PROV:^TMP("PXKENC",$J,VISIT,"CPT",REC,0),1:"")
179 ...Q:$P(NOD1,U)=""
180 ...S Q="00"_+$P(NOD1,U,16),Q=$S(+Q:$E(Q,$L(Q)-1,$L(Q)),1:"01")
181 ...S CPT=$P(NOD1,U),M=0,MOD=""
182 ...F I=1:1:5 S M=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M)) Q:'M D
183 ....S MOD=MOD_$S(MOD'="":";",1:"")
184 ....S MOD=MOD_$P(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M,0),U)
185 ...S ECXVIST("CPT"_CNT)=$$CPT^ECXUTL3(CPT,MOD,Q),CNT=CNT+1
186 ...K ^TMP("PXKENC",$J,VISIT,"CPT",REC)
187 ..Q:CNT>8
188 .Q:CNT>8 S REC=0
189 .F S REC=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC)) Q:'REC D Q:CNT>8
190 ..S CPT="",NOD1=$G(^TMP("PXKENC",$J,VISIT,"CPT",REC,0))
191 ..Q:$P(NOD1,U)=""
192 ..S Q="00"_+$P(NOD1,U,16),Q=$S(+Q:$E(Q,$L(Q)-1,$L(Q)),1:"01")
193 ..S CPT=$P(NOD1,U),M=0,MOD=""
194 ..F I=1:1:5 S M=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M)) Q:'M D
195 ...S MOD=MOD_$S(MOD'="":";",1:"")
196 ...S MOD=MOD_$P(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M,0),U)
197 ..S ECXVIST("CPT"_CNT)=$$CPT^ECXUTL3(CPT,MOD,Q),CNT=CNT+1
198 ..K ^TMP("PXKENC",$J,VISIT,"CPT",REC)
199 ..Q:CNT>8
200 S:ECXVIST("CPT1")="" ECXVIST("CPT1")=9919901
201 ;ao, ir, mst, pge, hnc
202 S (AO,IR,MST,PGE,HNC)=""
203 I $D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800)) D
204 .S AO=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,2)
205 .S IR=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,3),MST=$P(^(800),U,5)
206 .S PGE=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,4),HNC=$P(^(800),U,6)
207 .S ECXVIST("AO")=$S(AO=0:"N",AO=1:"Y",1:"")
208 .S ECXVIST("IR")=$S(IR=0:"N",IR=1:"Y",1:"")
209 .S ECXVIST("MST")=$S(MST=0:"N",MST=1:"Y",1:"")
210 .S ECXVIST("PGE")=$S(PGE=0:"N",PGE=1:"Y",1:"")
211 .S ECXVIST("HNC")=$S(HNC=0:"N",HNC=1:"Y",1:"")
212 Q
Note: See TracBrowser for help on using the repository browser.