source: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXQSR.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 7.1 KB
Line 
1ECXQSR ;ALB/JAP,BIR/PTD-DSS QUASAR Extract ; 7/31/07 11:19pm
2 ;;3.0;DSS EXTRACTS;**11,8,13,26,24,34,33,35,39,43,46,49,64,71,84,92,106,105**;Dec 22, 1997;Build 70
3BEG ;entry point from option
4 I '$O(^ACK(509850.8,0)) W !,"You must be using the Quality Audiology & Speech Pathology",!,"Audit & Review (QUASAR) software to run this extract.",!! Q
5 I '$D(^ACK(509850.8,1,"DSS")) W !,"Linkage has not been established between QUASAR and the DSS UNIT file (#724).",!! Q
6 I '$O(^ACK(509850.6,0)) W !,"There is no data in the A&SP CLINIC VISIT file (#509850.6).",!! Q
7 D SETUP I ECFILE="" Q
8 D ^ECXTRAC,^ECXKILL
9 Q
10START ;entry point from tasked job
11 N ERR,ECXQDT,ECXNPRFI
12 S QFLG=0,ECED=ECED+.9,ECD=ECSD1,ECXQV=""
13 D QINST I $D(ERR) Q
14 S ECL=+^ACK(509850.8,1,0),ECLINK=^ACK(509850.8,1,"DSS")
15 F S ECD=$O(^ACK(509850.6,"B",ECD)),ECDA=0 Q:(ECD>ECED)!('ECD)!(QFLG) D
16 .I +ECXQV=3,ECD<ECXQDT S ECXQV=2.0
17 .F S ECDA=$O(^ACK(509850.6,"B",ECD,ECDA)) Q:'ECDA D UPDATE Q:QFLG
18 Q
19QINST ;Get installed information for QUASAR
20 N ARR,IENS,QVIEN,INTIEN
21 S ECXQDT=""
22 D FILE^DID(509850.6,,"VERSION","ARR","ERR")
23 S ECXQV=$G(ARR("VERSION")) I +ECXQV=0 S ERR=1 Q
24 S QVIEN=$$FIND1^DIC(9.4,"","X","QUASAR") I +QVIEN<1 S ERR=1 Q
25 S IENS=","_QVIEN_","
26 S INTIEN=$$FIND1^DIC(9.49,IENS,"X",ECXQV) I +INTIEN<1 S ERR=1 Q
27 S IENS=INTIEN_","_QVIEN,ECXQDT=$$GET1^DIQ(9.49,IENS,2,"I")
28 Q
29UPDATE ;create record for each unique CPT code for clinic visit
30 N ARY,ECZNODE,CPT,LOC,MOD,STR,VOL,XX,ECTP,ECV
31 Q:'$D(^ACK(509850.6,ECDA,0))
32 S ECZNODE=^ACK(509850.6,ECDA,0),EC2NODE=$G(^ACK(509850.6,ECDA,2))
33 S ECDT=$P(ECZNODE,U),ECDAY=$$ECXDATE^ECXUTL(ECDT,ECXYM)
34 S ECTIME=$$ECXTIME^ECXUTL(ECDT) S:$P(ECDT,".",2)="" ECTIME="000000"
35 S ECXDFN=$P(ECZNODE,U,2)
36 Q:'$$PATDEM^ECXUTL2(ECXDFN,ECD,"1;3;5")
37 S OK=$$PAT^ECXUTL3(ECXDFN,ECDT,"1;5",.ECXPAT)
38 I 'OK S ECXERR=1 K ECXPAT Q
39 ;OEF/OIF data
40 S ECXOEF=ECXPAT("ECXOEF")
41 S ECXOEFDT=ECXPAT("ECXOEFDT")
42 ;
43 S ECHL="",ECXDIV=$P($G(^ACK(509850.6,ECDA,5)),U),ECSTOP=$P(EC2NODE,U)
44 S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV) ; Get Production Division
45 Q:ECSTOP=""
46 S (ECHLS,ECHL2S)="000",ECAC=$P($G(ECZNODE),U,6)
47 I ECAC D
48 .S ECHL=+$P($G(^SC(ECAC,0)),U,7),ECHL2=+$P($G(^(0)),U,18) I ECHL D
49 ..S ECHLS=$P($G(^DIC(40.7,+ECHL,0)),U,2),ECHL2S=$P($G(^DIC(40.7,+ECHL2,0)),U,2)
50 ..S ECHLS=$$RJ^XLFSTR(ECHLS,3,0),ECHL2S=$$RJ^XLFSTR(ECHL2S,3,0)
51 S ECDSS=ECHLS_ECHL2S
52 I ECXLOGIC>2003 D
53 .I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECDSS=$$TSMAP^ECXUTL4(ECXTS)
54 S ECDU=$S(ECSTOP["A":$P(ECLINK,U),ECSTOP["S":$P(ECLINK,U,2),1:"")
55 Q:'ECDU
56 S ECDSSU=$G(^ECD(ECDU,0)),ECCS=+$P(ECDSSU,U,4),(ECO,ECM)=+$P(ECDSSU,U,3),ECXDSSD=$E($P(ECDSSU,U,5),1,10)
57 Q:'$O(^ACK(509850.6,ECDA,3,0))
58 ;Create local array of procedure codes and # of times each procedure
59 ; was performed.
60 F I=1:1:4 S @("ECXICD9"_I)=""
61 S (ECDIA,ECXPPC,ECXPRV1,ECXPRV2,ECXPRV3,ECUN1NPI)=""
62 ;if QUASAR v2
63 I +ECXQV=2 D
64 .S ECXPRV1=$P(EC2NODE,U,7),ECXPRV2=$P(EC2NODE,U,3),ECXPRV3=$P(EC2NODE,U,5),ECPN=0
65 .S ECPR1NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV1,ECD)
66 .S:+ECPR1NPI'>0 ECPR1NPI="" S ECPR1NPI=$P(ECPR1NPI,U)
67 .S ECPR2NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV2,ECD)
68 .S:+ECPR2NPI'>0 ECPR2NPI="" S ECPR2NPI=$P(ECPR2NPI,U)
69 .S ECPR3NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV3,ECD)
70 .S:+ECPR3NPI'>0 ECPR3NPI="" S ECPR3NPI=$P(ECPR3NPI,U)
71 .F S ECPN=$O(^ACK(509850.6,ECDA,3,ECPN)) Q:'ECPN D
72 ..S XX=^ACK(509850.6,ECDA,3,ECPN,0),XX=$P(XX,U),XX=$P($G(^ACK(509850.4,XX,0)),U),ECXCPT=$E($$CPT^ECXUTL3(XX),1,5)
73 ..I ECXCPT]"" D
74 ...I '$D(LOC(ECXCPT)) S LOC(ECXCPT)=0_U_ECXPRV1
75 ...S $P(LOC(ECXCPT),U)=$P(LOC(ECXCPT),U)+1
76 .S ECIEN=$O(^ACK(509850.6,ECDA,1,0)),ECDIA=$P($G(^ICD9(+$G(^ACK(509850.6,ECDA,1,ECIEN,0)),0)),U)
77 .F I=1:1:4 S ECIEN=$O(^ACK(509850.6,ECDA,1,ECIEN)) Q:'+ECIEN D
78 ..S @("ECXICD9"_I)=$P($G(^ICD9(+$P(^ACK(509850.6,ECDA,1,ECIEN,0),U),0)),U)
79 ;if QUASAR v3
80 I +ECXQV=3 D
81 .N CPT,DIA,I,J,MOD,MOD1,P,STR,VOL,ECTP,ARY,ECP,ECPN
82 .S ECXPRV2=$G(^ACK(509850.6,ECDA,2.7,1,0)),ECXPRV3=$G(^ACK(509850.6,ECDA,2.7,2,0))
83 .S ECPN=0 F S ECPN=$O(^ACK(509850.6,ECDA,3,ECPN)) Q:'ECPN D
84 ..S CPT=^ACK(509850.6,ECDA,3,ECPN,0),ECXCPT=$P(CPT,U),ECTP=+$P(CPT,U,5),ECV=1,ECP=""
85 ..Q:ECXCPT=""
86 ..I ECTP D
87 ...S CPT=$G(^ACK(509850.6,ECDA,7,ECTP,0)),ECP=$P(CPT,U)
88 ...S ECP=$S(ECP<90000:$P($G(^EC(725,+ECP,0)),U,2)_"N",1:$P($G(^EC(725,+ECP,0)),U,2)_"L")
89 ...S VOL=+$P(CPT,U,2),ECXPRV1=$P(CPT,U,3)
90 ..I 'ECTP S VOL=+$P(CPT,U,3),ECXPRV1=$P(CPT,U,4)
91 ..S ECXCPT=$E($$CPT^ECXUTL3(ECXCPT),1,5),ECXMOD="",MOD=0
92 ..F S MOD=$O(^ACK(509850.6,ECDA,3,ECPN,1,MOD)) Q:'MOD D
93 ...S MOD1=+^ACK(509850.6,ECDA,3,ECPN,1,MOD,0) D:MOD1
94 ....S ECXMOD=ECXMOD_MOD1_";"
95 ..F I=1:1:$L(ECXMOD,";") I $G(ARY(ECXCPT))'[$P(ECXMOD,";",I) D
96 ...S ARY(ECXCPT)=$G(ARY(ECXCPT))_$P(ECXMOD,";",I)_";"
97 ..S:VOL ECV=VOL
98 ..S ECV=ECV+$G(LOC(ECXCPT)),LOC(ECXCPT)=ECV_U_ECXPRV1_U_ECP
99 .S ECIEN=0 F S ECIEN=$O(^ACK(509850.6,ECDA,1,ECIEN)) Q:'ECIEN D
100 ..S DIA=^ACK(509850.6,ECDA,1,ECIEN,0),P=$P(DIA,U,2),P=$S(P=1:"P",1:"S")
101 ..S CNT=$G(STR(P))+1,STR(P,CNT)=$P($G(^ICD9(+DIA,0)),U),STR(P)=CNT
102 .S ECDIA=$G(STR("P",1))
103 .F I=1:1:4 Q:'$D(STR("P",I+1)) S @("ECXICD9"_I)=STR("P",I)
104 .S:ECDIA="" ECDIA=$G(STR("S",1)),I=2
105 .F J=I:1:4 Q:'$D(STR("S",J)) S @("ECXICD9"_J)=STR("S",J)
106 Q:('$D(LOC))!('$O(^ACK(509850.6,ECDA,1,0)))
107 ;- Ord Div, Contract St/End Dates, Contract Type placeholders for FY2002
108 S (ECXODIV,ECXCSDT,ECXCEDT,ECXCTYP)=""
109 ;set up Provider Person class
110 S (ECXCPT,ECXPPC1,ECXPPC2,ECXPPC3)=""
111 S:ECXPRV2'="" ECXPPC2=$$PRVCLASS^ECXUTL(ECXPRV2,ECD)
112 S:ECXPRV3'="" ECXPPC3=$$PRVCLASS^ECXUTL(ECXPRV3,ECD)
113 N DA,DIC,DIK,DR,FILEN,DIQ,XVAR,II,DI
114 F II=2,3 S XVAR="ECXPRV"_II I @XVAR'="" D
115 .S DA=@XVAR,(DIC,FILEN)=509850.3,DR=".01",DIQ="ECXQSR",DIQ(0)="I" D EN^DIQ1
116 .S DA=ECXQSR(FILEN,DA,DR,"I"),(DIC,FILEN)=8930.3 D EN^DIQ1 S @XVAR=2_ECXQSR(FILEN,DA,DR,"I") K DA,DIC,DR,DIQ,ECXQSR
117 ; -Observation Patient Indicator (yes/no)
118 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECDSS)
119 ; -CNH status (YES/NO)
120 S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN)
121 ;get encounter classification
122 S (ECXAO,ECXECE,ECXIR,ECXMIL,ECXHNC)="",ECXVISIT=$P($G(^ACK(509850.6,ECDA,6)),U,3)
123 I ECXVISIT'="" D
124 .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q
125 .S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE"))
126 .S ECXIR=$G(ECXVIST("IR")),ECXMIL=$G(ECXVIST("MST")),ECXHNC=$G(ECXVIST("HNC"))
127 ; -Head and Neck Cancer Indicator
128 S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
129 ;get enrollment data (category, status and priority)
130 I $$ENROLLM^ECXUTL2(ECXDFN)
131 ; -Get national patient record flag Indicator if exist
132 D NPRF^ECXUTL5
133 ; -If no encounter number don't file record
134 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECDT,ECXTS,ECXOBS,ECHEAD,ECDSS,)
135 Q:ECXENC=""
136 ;Loop through array of unique procedures. Create record in ECODE.
137 S CPT="" F S CPT=$O(LOC(CPT)) Q:CPT="" D
138 .S ECV=+$P(LOC(CPT),U),ECXCPT=$$CPT^ECXUTL3(CPT,$G(ARY(CPT)),ECV)
139 .S ECXPRV1=$P(LOC(CPT),U,2)
140 .S:ECXPRV1'="" ECXPPC1=$$PRVCLASS^ECXUTL(ECXPRV1,ECD),ECXPRV1=2_ECXPRV1
141 .S ECP=$P(LOC(CPT),U,3) I ECP="" S ECP=$$CPT^ECXUTL3(CPT,"",ECV)
142 .D FILE^ECXQSR1
143 K CPT,LOC
144 Q
145SETUP ;Set required input for ECXTRAC
146 S ECHEAD="ECQ"
147 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
148 Q
149QUE ;Entry point for the background requeuing handled by ECXTAUTO.
150 D SETUP,QUE^ECXTAUTO,^ECXKILL Q
Note: See TracBrowser for help on using the repository browser.