Changeset 623 for WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUTL3.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUTL3.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUTL3.m
r613 r623 1 ECXUTL3 ;ALB/GTS - Utilities for DSS Extracts ; 9/28/07 1:38pm 2 ;;3.0;DSS EXTRACTS;**11,24,32,33,35,37,39,42,46,92,105**;Dec 22,1997;Build 70 3 ; 4 OUTPTTM(ECXDFN,ECXDT) ;* Return PC Team from PCMM files or DPT 5 ; Variables - 6 ; ECXDFN - IEN from Patient file (Required) 7 ; ECXDT - Relevant Date for Primary Care Team 8 ; (Defaults to DT) 9 ; 10 ; Returned: ECXTM - 11 ; Pointer to team file (#404.51) 12 ; or, if error or none defined, returns 0 13 ; 14 Q:'$G(ECXDFN) 0 ;** Quit if ECXDFN not defined 15 N ECXTM 16 S:'$D(ECXDT) ECXDT=DT 17 I $T(OUTPTTM^SDUTL3)[",SCDATE" D 18 .S ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDT) 19 I $T(OUTPTTM^SDUTL3)'[",SCDATE" D 20 .S ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN) 21 I ECXTM=0 D 22 .S ECXTM=+$P($G(^DPT(+ECXDFN,"PC")),U,2) 23 Q ECXTM 24 ; 25 OUTPTPR(ECXDFN,ECXDT) ;* Return PC Provider from PCMM files or DPT 26 ; Variables - 27 ; ECXDFN - IEN from Patient file (Required) 28 ; ECXDT - Relevant Date for Primary Care Provider 29 ; (Defaults to DT) 30 ; 31 ; Returned: ECXPR - 32 ; Pointer to file #200 33 ; or, if error or none defined, returns a 0 34 ; 35 Q:'$G(ECXDFN) 0 ;** Quit if ECXDFN not defined 36 N ECXPR 37 S:'$D(ECXDT) ECXDT=DT 38 I $T(OUTPTPR^SDUTL3)[",SCDATE" D 39 .S ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDT) 40 I $T(OUTPTPR^SDUTL3)'[",SCDATE" D 41 .S ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN) 42 I ECXPR=0 D 43 .S ECXPR=+$G(^DPT(+ECXDFN,"PC")) 44 Q ECXPR 45 ; 46 PAT(ECXDFN,ECXDATE,ECXDATA,ECXPAT) ;Return basic patient data for extract 47 ; Will not return data associated with test patients (SSN begin w 00000) 48 ; Variables - 49 ; Input ECXDFN - Patient internal entry number, DFN file#2; required 50 ; ECXDATE- Date used to get specific data from GETSTAT^DGMSTAPI 51 ; for MST. If no date, defaults to today's date, 52 ; standard FM format, optional 53 ; ECXDATA- Code indicating which data to return, optional. 54 ; If code not specified then returns all. Codes are: 55 ; 1 - DEM^VADPT (demographic data) 56 ; 2 - ADD^VADPT (current address) 57 ; 3 - ELIG^VADPT (eligibility & enrollment location) 58 ; 4 - OPD^VADPT (other patient data) 59 ; 5 - SVC^VADPT & GETSTAT^DGMSTAPI (service & MST inf) 60 ; ECXPAT(- Passed by reference; required 61 ; 62 ; Output: 63 ; ECXPAT 0 error or test patient no data in ECXPAT array 64 ; 1 data returned in ECXPAT array 65 ; ECXPAT( Local array with patient data. 66 ; 67 N SSN,I,ECXCOD,ECXDAT,DFN,VAPA,VADM,VAEL,VAPD,VASV,STR,ECXAR,DIC,DIQ,RCNUM,RCVAL,COLMETH 68 N DA,DR,PELG,MELIG,ZIP,MPI 69 I ECXDFN="" Q 0 70 S SSN=$$GET1^DIQ(2,ECXDFN,.09,"I"),DFN=ECXDFN,ECXPAT=0 71 I $E(SSN,1,3)="000"!(SSN="") K ECXPAT Q 0 ;test patient 72 ;test patient extended checks; mtl extract excluded 73 I $G(ECHEAD)'="MTL",'$$SSN^ECXUTL5(SSN) K ECXPAT Q 0 74 S STR="NAME;SSN;DOB;SEX;RACE;RELIGION;STATE;COUNTY;ZIP;SC%;MEANS;ELIG;" 75 S STR=STR_"EMPLOY;AO STAT;IR STAT;EC STAT;POW STAT;POW LOC;MST STAT;" 76 S STR=STR_"ENROLL LOC;MPI;VIETNAM;POS;MARITAL" 77 ;initialize return array values 78 F I=1:1 S ECXDAT=$P(STR,";",I) Q:ECXDAT="" S ECXPAT(ECXDAT)="" 79 F I=1:1:$L(ECXDATA,";") S ECXDAT=$P(ECXDATA,";",I) I ECXDAT'="" D 80 . S ECXCOD(ECXDAT)="" 81 ; 82 ;- Get ICN if MPI installed 83 S X="MPIF001" X ^%ZOSF("TEST") I $T D 84 .; 85 .;- Get 1st piece (either ICN # or -1 if error) 86 . S MPI=+$$GETICN^MPIF001(DFN) 87 .; 88 .;- If error, set to null 89 . S ECXPAT("MPI")=$S(MPI>0:MPI,1:"") 90 D ;get demographic data 91 . I ECXDATA'="",'$D(ECXCOD(1)) Q 92 . D DEM^VADPT 93 . S ECXPAT("NAME")=$E($P(VADM(1),",")_" ",1,4) 94 . S ECXPAT("SSN")=$P(VADM(2),U),ECXPAT("MARITAL")=$P(VADM(10),U) 95 . S ECXPAT("DOB")=$$ECXDOB^ECXUTL($P(VADM(3),U)) 96 . S ECXPAT("SEX")=$P(VADM(5),U),ECXPAT("RELIGION")=$P(VADM(9),U) 97 . S DIC=10,DR=2,DA=+VADM(8),DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 98 . S ECXPAT("RACE")=$G(ECXAR(10,DA,DR,"I")),ECXPAT=1 99 . ;add new race and ethnicity fields for FY2003 100 . S (ECXPAT("ETHNIC"),ECXPAT("RACE1"))="" 101 . S X="DGUTL4" X ^%ZOSF("TEST") I $T D 102 .. S COLMETH=$$PTR2CODE^DGUTL4($G(VADM(11,1,1)),3,4) I COLMETH="S" D 103 ... S ECXPAT("ETHNIC")=$$PTR2CODE^DGUTL4(+$G(VADM(11,1)),2,4) 104 .. S (RCVAL,RCNUM)="" 105 .. F S RCNUM=$O(VADM(12,RCNUM)) Q:RCNUM="" Q:RCVAL="C" S COLMETH=$$PTR2CODE^DGUTL4(+$G(VADM(12,RCNUM,1)),3,4) I COLMETH="S" D 106 ... S RCVAL=$$PTR2CODE^DGUTL4(+$G(VADM(12,RCNUM)),1,4) 107 ... I RCVAL="C" S ECXPAT("RACE1")=RCVAL Q 108 ... S ECXPAT("RACE1")=ECXPAT("RACE1")_RCVAL 109 D ;get address information 110 . I ECXDATA'="",'$D(ECXCOD(2)) Q 111 . D ADD^VADPT 112 . S DIC=5,DR=2,DA=+VAPA(5),DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 113 . S ECXPAT("STATE")=$G(ECXAR(5,DA,DR,"I")) 114 . S DIC=5,DA=+VAPA(5),DR=3,DR(5.01)=2,DA(5.01)=+VAPA(7),DIQ="ECXAR" 115 . S DIQ(0)="I" D EN^DIQ1 116 . S ECXPAT("COUNTY")=$G(ECXAR(5.01,DA(5.01),2,"I")) 117 . S ECXPAT("ZIP")=$P(VAPA(11),U,2),ECXPAT=1 118 D ;get eligibility information 119 . I ECXDATA'="",'$D(ECXCOD(3)) Q 120 . D ELIG^VADPT 121 . S PELG=$P(VAEL(1),U),MELIG=$S(PELG="":"",1:$$GET1^DIQ(8,PELG,8,"I")) 122 . S ECXPAT("POS")=$P($G(^DIC(21,+VAEL(2),0)),U,3) 123 . S ECXPAT("SC STAT")=$S(+VAEL(3):"Y",+VAEL(3)=0:"N",1:"") 124 . S ECXPAT("SC%")=$P(VAEL(3),U,2) 125 . S ECXPAT("VET")=$S(VAEL(4):"Y",VAEL(4)=0:"N",1:"") 126 . S ECXPAT("MEANS")=$P(VAEL(9),U),ECXPAT=1 127 . S ECXPAT("ELIG")=$$ELIG(MELIG,ECXPAT("SC%")) 128 . ;get enrollment location 129 . S DIC=2,DR=27.02,DA=ECXDFN,DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 130 . S ECXDAT=$G(ECXAR(2,ECXDFN,DR,"I")) I ECXDAT K ECXAR D 131 . . S DIC=4,DA=ECXDAT,DR=99,DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 132 . . S ECXPAT("ENROLL LOC")=ECXAR(4,ECXDAT,DR,"I") 133 . ;get Emergency Response Indicator (FEMA) 134 . S ECXPAT("ERI")=$$GET1^DIQ(2,ECXDFN,.181,"I") 135 D ;get other patient information 136 . I ECXDATA'="",'$D(ECXCOD(4)) Q 137 . D OPD^VADPT 138 . S ECXPAT("EMPLOY")=$P(VAPD(7),U),ECXPAT=1 139 D ;get service information 140 . I ECXDATA'="",'$D(ECXCOD(5)) Q 141 . D SVC^VADPT 142 . S ECXPAT("VIETNAM")=$S(VASV(1):"Y",VASV(2)=0:"N",1:"U") 143 . S ECXPAT("AO STAT")=$S(VASV(2):"Y",VASV(2)=0:"N",1:"U") 144 . S ECXPAT("IR STAT")=$S(VASV(3):"Y",VASV(3)=0:"N",1:"U") 145 . S ECXPAT("EC STAT")=$$GET1^DIQ(2,ECXDFN,.322013,"I") 146 . S ECXPAT("POW STAT")=$S(VASV(4):"Y",VASV(4)=0:"N",1:"U") 147 . S ECXPAT("POW LOC")=$P(VASV(4,3),U),ECXPAT=1 148 . S ECXPAT("PHI")=$S(VASV(9)=1:"Y",VASV(9)=0:"N",1:"") 149 . ;- Agent Orange Location (K=Korean DMZ,V=Vietnam) 150 . S ECXPAT("AOL")=$P($G(VASV(2,5)),U) 151 . ;get patient OEF/OIF status and date of return 152 . D OEFDATA^ECXUTL4 153 . ; 154 . ;get patient current MST status 155 . I ECXDATE'="",ECXDATE'["." S ECXDATE=ECXDATE+.9 156 . S X="DGMSTAPI" X ^%ZOSF("TEST") I $T D 157 . . S ECXDAT=$$GETSTAT^DGMSTAPI(DFN,ECXDATE) 158 . . S ECXPAT("MST STAT")=$S(+ECXDAT>0:$P(ECXDAT,U,2),1:"") 159 I 'ECXPAT K ECXPAT Q 0 160 Q 1 161 ; 162 ELIG(ECXELIG,ECXSVCP) ;Converts veteran eligibility code to NPCD code 163 ; Variables - 164 ; Input ECXELIG - Pointer to MAS ELIGIBILITY CODE file #8.1 165 ; ECXSVCP - Number value rep. service connected percentage. 166 ; 167 ; Output: 168 ; ECXNCPD NPCD Eligibility Code 169 ; 170 N TEXT,IEN,SCPER,FND,NPCD,I,ECXBG,ECXEN,ECXNPCD 171 I ECXELIG="" Q "" 172 F I=1:1 S TEXT=$P($T(ELGTXT+I),";",3,999) Q:TEXT="END" D I $D(NPCD) Q 173 . S IEN=$P(TEXT,";"),SCPER=$P(TEXT,";",2) 174 . I ECXELIG=IEN D 175 . . I SCPER="" S NPCD=$P(TEXT,";",3) Q 176 . . S ECXBG=$S($E(SCPER)="<":0,$E(SCPER)=">":$P(SCPER,">",2)+1,SCPER["-":+SCPER,1:"") 177 . . S ECXEN=$S($E(SCPER)="<":$P(SCPER,"<",2),$E(SCPER)=">":100,SCPER["-":$P(SCPER,"-",2),1:"") 178 . . I ECXSVCP'<ECXBG,ECXSVCP'>ECXEN S NPCD=$P(TEXT,";",3) 179 S ECXNPCD=$G(NPCD) 180 Q ECXNPCD 181 ELGTXT ;Eligibility codes 182 ;;1;>49;10;SC 50-100% 183 ;;2;;20;Aid & Attendance 184 ;;15;;21;Housebound 185 ;;16;;22;Mexican Border War 186 ;;17;;23;WWI 187 ;;18;;24;POW 188 ;;3;40-49;30;SC 40-49% 189 ;;3;30-39;31;SC 30-39% 190 ;;3;20-29;32;SC 20-29% 191 ;;3;10-19;33;SC 10-19% 192 ;;3;<10;34;SC less than 10% 193 ;;4;;40;NSC - VA Pension 194 ;;5;;50;NSC 195 ;;21;;60;Catastrophic Disability 196 ;;12;;101;CHAMPVA 197 ;;13;;102;Collateral of Veteran 198 ;;14;;103;Employee 199 ;;6;;104;Other Federal Agency 200 ;;7;;105;Allied Veteran 201 ;;8;;106;Humanitarian Emergency 202 ;;9;;107;Sharing Agreement 203 ;;10;;108;Reimbursable Insurance 204 ;;19;;109;TRICARE/CHAMPUS 205 ;;22;;25;Purple Heart Recipient 206 ;;END 207 ; 208 CPT(ECXCPT,ECXMOD,ECXQUA) ;Returns a str with CPT code and modifier codes 209 ;Return string is composed of a 5 character CPT code 2 character quantity 210 ;plus up to 5 modifier codes, 2 characters each. 211 ; Variables - 212 ; Input ECXCPT - Pointer value to the CPT file (#81) 213 ; ECXMOD - A string with pointer values to the CPT 214 ; MODIFIER file (#81.3) separated by ";" 215 ; ECXQUA - Number of time this procedure performed 216 ; 217 ; Output: 218 ; CPTMOD - String of up to 17 characters, 5 character CPT 219 ; code 2 character qty plus up to 5 2-character 220 ; code modifiers. 221 ; 222 N CPT,MOD,I,CPTMOD 223 S ECXQUA=$G(ECXQUA,"01"),ECXMOD=$G(ECXMOD) 224 S:$L(ECXQUA)'=2 ECXQUA="0"_ECXQUA 225 S CPT=$$CPT^ICPTCOD(ECXCPT,"") I +CPT=-1 Q "" 226 S CPT=$P(CPT,U,2)_ECXQUA 227 F I=1:1:99 I $P(ECXMOD,";",I)'="" D 228 . S MOD=$$MOD^ICPTMOD($P(ECXMOD,";",I),"I","") 229 . I +MOD>0,$P(MOD,U,2)'="99" S CPT=CPT_$P(MOD,U,2) 230 S CPTMOD=$TR($E(CPT,1,17)," ") 231 Q CPTMOD 232 ; 233 CPTOUT(ECXCPT) ;output transform for CPT code plus modifiers 234 ;input ECXCPT - character string of CPT code plus modifiers (required) 235 ; 236 N J,CPTX,MOD,MODS,MODX,CPTMOD 237 Q:$G(ECXCPT)="" "" 238 S (CPTMOD,MODX)="" 239 S CPTX="("_+$E(ECXCPT,6,7)_") "_$E(ECXCPT,1,5),MODS=$E(ECXCPT,8,17) 240 F J=1:2:9 S MOD=$E(MODS,J,J+1) Q:MOD="" D 241 .I J>1 S MODX=MODX_", "_MOD Q 242 .S MODX=MODX_"-"_MOD 243 S:$L(CPTX)>3 CPTMOD=CPTMOD_CPTX_MODX 244 Q CPTMOD 1 ECXUTL3 ;ALB/GTS - Utilities for DSS Extracts ; 11/2/06 9:07am 2 ;;3.0;DSS EXTRACTS;**11,24,32,33,35,37,39,42,46,92**;Dec 22,1997;Build 30 3 ; 4 OUTPTTM(ECXDFN,ECXDT) ;* Return PC Team from PCMM files or DPT 5 ; Variables - 6 ; ECXDFN - IEN from Patient file (Required) 7 ; ECXDT - Relevant Date for Primary Care Team 8 ; (Defaults to DT) 9 ; 10 ; Returned: ECXTM - 11 ; Pointer to team file (#404.51) 12 ; or, if error or none defined, returns 0 13 ; 14 Q:'$G(ECXDFN) 0 ;** Quit if ECXDFN not defined 15 N ECXTM 16 S:'$D(ECXDT) ECXDT=DT 17 I $T(OUTPTTM^SDUTL3)[",SCDATE" D 18 .S ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDT) 19 I $T(OUTPTTM^SDUTL3)'[",SCDATE" D 20 .S ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN) 21 I ECXTM=0 D 22 .S ECXTM=+$P($G(^DPT(+ECXDFN,"PC")),U,2) 23 Q ECXTM 24 ; 25 OUTPTPR(ECXDFN,ECXDT) ;* Return PC Provider from PCMM files or DPT 26 ; Variables - 27 ; ECXDFN - IEN from Patient file (Required) 28 ; ECXDT - Relevant Date for Primary Care Provider 29 ; (Defaults to DT) 30 ; 31 ; Returned: ECXPR - 32 ; Pointer to file #200 33 ; or, if error or none defined, returns a 0 34 ; 35 Q:'$G(ECXDFN) 0 ;** Quit if ECXDFN not defined 36 N ECXPR 37 S:'$D(ECXDT) ECXDT=DT 38 I $T(OUTPTPR^SDUTL3)[",SCDATE" D 39 .S ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDT) 40 I $T(OUTPTPR^SDUTL3)'[",SCDATE" D 41 .S ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN) 42 I ECXPR=0 D 43 .S ECXPR=+$G(^DPT(+ECXDFN,"PC")) 44 Q ECXPR 45 ; 46 PAT(ECXDFN,ECXDATE,ECXDATA,ECXPAT) ;Return basic patient data for extract 47 ; Will not return data associated with test patients (SSN begin w 00000) 48 ; Variables - 49 ; Input ECXDFN - Patient internal entry number, DFN file#2; required 50 ; ECXDATE- Date used to get specific data from GETSTAT^DGMSTAPI 51 ; for MST. If no date, defaults to today's date, 52 ; standard FM format, optional 53 ; ECXDATA- Code indicating which data to return, optional. 54 ; If code not specified then returns all. Codes are: 55 ; 1 - DEM^VADPT (demographic data) 56 ; 2 - ADD^VADPT (current address) 57 ; 3 - ELIG^VADPT (eligibility & enrollment location) 58 ; 4 - OPD^VADPT (other patient data) 59 ; 5 - SVC^VADPT & GETSTAT^DGMSTAPI (service & MST inf) 60 ; ECXPAT(- Passed by reference; required 61 ; 62 ; Output: 63 ; ECXPAT 0 error or test patient no data in ECXPAT array 64 ; 1 data returned in ECXPAT array 65 ; ECXPAT( Local array with patient data. 66 ; 67 N SSN,I,ECXCOD,ECXDAT,DFN,VAPA,VADM,VAEL,VAPD,VASV,STR,ECXAR,DIC,DIQ,RCNUM,RCVAL,COLMETH 68 N DA,DR,PELG,MELIG,ZIP,MPI 69 I ECXDFN="" Q 0 70 S SSN=$$GET1^DIQ(2,ECXDFN,.09,"I"),DFN=ECXDFN,ECXPAT=0 71 I $E(SSN,1,5)="00000"!(SSN="") K ECXPAT Q 0 ;test patient 72 S STR="NAME;SSN;DOB;SEX;RACE;RELIGION;STATE;COUNTY;ZIP;SC%;MEANS;ELIG;" 73 S STR=STR_"EMPLOY;AO STAT;IR STAT;EC STAT;POW STAT;POW LOC;MST STAT;" 74 S STR=STR_"ENROLL LOC;MPI;VIETNAM;POS;MARITAL" 75 ;initialize return array values 76 F I=1:1 S ECXDAT=$P(STR,";",I) Q:ECXDAT="" S ECXPAT(ECXDAT)="" 77 F I=1:1:$L(ECXDATA,";") S ECXDAT=$P(ECXDATA,";",I) I ECXDAT'="" D 78 . S ECXCOD(ECXDAT)="" 79 ; 80 ;- Get ICN if MPI installed 81 S X="MPIF001" X ^%ZOSF("TEST") I $T D 82 .; 83 .;- Get 1st piece (either ICN # or -1 if error) 84 . S MPI=+$$GETICN^MPIF001(DFN) 85 .; 86 .;- If error, set to null 87 . S ECXPAT("MPI")=$S(MPI>0:MPI,1:"") 88 D ;get demographic data 89 . I ECXDATA'="",'$D(ECXCOD(1)) Q 90 . D DEM^VADPT 91 . S ECXPAT("NAME")=$E($P(VADM(1),",")_" ",1,4) 92 . S ECXPAT("SSN")=$P(VADM(2),U),ECXPAT("MARITAL")=$P(VADM(10),U) 93 . S ECXPAT("DOB")=$$ECXDOB^ECXUTL($P(VADM(3),U)) 94 . S ECXPAT("SEX")=$P(VADM(5),U),ECXPAT("RELIGION")=$P(VADM(9),U) 95 . S DIC=10,DR=2,DA=+VADM(8),DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 96 . S ECXPAT("RACE")=$G(ECXAR(10,DA,DR,"I")),ECXPAT=1 97 . ;add new race and ethnicity fields for FY2003 98 . S (ECXPAT("ETHNIC"),ECXPAT("RACE1"))="" 99 . S X="DGUTL4" X ^%ZOSF("TEST") I $T D 100 .. S COLMETH=$$PTR2CODE^DGUTL4($G(VADM(11,1,1)),3,4) I COLMETH="S" D 101 ... S ECXPAT("ETHNIC")=$$PTR2CODE^DGUTL4(+$G(VADM(11,1)),2,4) 102 .. S (RCVAL,RCNUM)="" 103 .. F S RCNUM=$O(VADM(12,RCNUM)) Q:RCNUM="" Q:RCVAL="C" S COLMETH=$$PTR2CODE^DGUTL4(+$G(VADM(12,RCNUM,1)),3,4) I COLMETH="S" D 104 ... S RCVAL=$$PTR2CODE^DGUTL4(+$G(VADM(12,RCNUM)),1,4) 105 ... I RCVAL="C" S ECXPAT("RACE1")=RCVAL Q 106 ... S ECXPAT("RACE1")=ECXPAT("RACE1")_RCVAL 107 D ;get address information 108 . I ECXDATA'="",'$D(ECXCOD(2)) Q 109 . D ADD^VADPT 110 . S DIC=5,DR=2,DA=+VAPA(5),DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 111 . S ECXPAT("STATE")=$G(ECXAR(5,DA,DR,"I")) 112 . S DIC=5,DA=+VAPA(5),DR=3,DR(5.01)=2,DA(5.01)=+VAPA(7),DIQ="ECXAR" 113 . S DIQ(0)="I" D EN^DIQ1 114 . S ECXPAT("COUNTY")=$G(ECXAR(5.01,DA(5.01),2,"I")) 115 . S ECXPAT("ZIP")=$P(VAPA(11),U,2),ECXPAT=1 116 D ;get eligibility information 117 . I ECXDATA'="",'$D(ECXCOD(3)) Q 118 . D ELIG^VADPT 119 . S PELG=$P(VAEL(1),U),MELIG=$S(PELG="":"",1:$$GET1^DIQ(8,PELG,8,"I")) 120 . S ECXPAT("POS")=$P($G(^DIC(21,+VAEL(2),0)),U,3) 121 . S ECXPAT("SC STAT")=$S(+VAEL(3):"Y",+VAEL(3)=0:"N",1:"") 122 . S ECXPAT("SC%")=$P(VAEL(3),U,2) 123 . S ECXPAT("VET")=$S(VAEL(4):"Y",VAEL(4)=0:"N",1:"") 124 . S ECXPAT("MEANS")=$P(VAEL(9),U),ECXPAT=1 125 . S ECXPAT("ELIG")=$$ELIG(MELIG,ECXPAT("SC%")) 126 . ;get enrollment location 127 . S DIC=2,DR=27.02,DA=ECXDFN,DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 128 . S ECXDAT=$G(ECXAR(2,ECXDFN,DR,"I")) I ECXDAT K ECXAR D 129 . . S DIC=4,DA=ECXDAT,DR=99,DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 130 . . S ECXPAT("ENROLL LOC")=ECXAR(4,ECXDAT,DR,"I") 131 . ;get Emergency Response Indicator (FEMA) 132 . S ECXPAT("ERI")=$$GET1^DIQ(2,ECXDFN,.181,"I") 133 D ;get other patient information 134 . I ECXDATA'="",'$D(ECXCOD(4)) Q 135 . D OPD^VADPT 136 . S ECXPAT("EMPLOY")=$P(VAPD(7),U),ECXPAT=1 137 D ;get service information 138 . I ECXDATA'="",'$D(ECXCOD(5)) Q 139 . D SVC^VADPT 140 . S ECXPAT("VIETNAM")=$S(VASV(1):"Y",VASV(2)=0:"N",1:"U") 141 . S ECXPAT("AO STAT")=$S(VASV(2):"Y",VASV(2)=0:"N",1:"U") 142 . S ECXPAT("IR STAT")=$S(VASV(3):"Y",VASV(3)=0:"N",1:"U") 143 . S ECXPAT("EC STAT")=$$GET1^DIQ(2,ECXDFN,.322013,"I") 144 . S ECXPAT("POW STAT")=$S(VASV(4):"Y",VASV(4)=0:"N",1:"U") 145 . S ECXPAT("POW LOC")=$P(VASV(4,3),U),ECXPAT=1 146 . S ECXPAT("PHI")=$S(VASV(9)=1:"Y",VASV(9)=0:"N",1:"") 147 . ;- Agent Orange Location (K=Korean DMZ,V=Vietnam) 148 . S ECXPAT("AOL")=$P($G(VASV(2,5)),U) 149 . ;get patient current MST status 150 . I ECXDATE'="",ECXDATE'["." S ECXDATE=ECXDATE+.9 151 . S X="DGMSTAPI" X ^%ZOSF("TEST") I $T D 152 . . S ECXDAT=$$GETSTAT^DGMSTAPI(DFN,ECXDATE) 153 . . S ECXPAT("MST STAT")=$S(+ECXDAT>0:$P(ECXDAT,U,2),1:"") 154 I 'ECXPAT K ECXPAT Q 0 155 Q 1 156 ; 157 ELIG(ECXELIG,ECXSVCP) ;Converts veteran eligibility code to NPCD code 158 ; Variables - 159 ; Input ECXELIG - Pointer to MAS ELIGIBILITY CODE file #8.1 160 ; ECXSVCP - Number value rep. service connected percentage. 161 ; 162 ; Output: 163 ; ECXNCPD NPCD Eligibility Code 164 ; 165 N TEXT,IEN,SCPER,FND,NPCD,I,ECXBG,ECXEN,ECXNPCD 166 I ECXELIG="" Q "" 167 F I=1:1 S TEXT=$P($T(ELGTXT+I),";",3,999) Q:TEXT="END" D I $D(NPCD) Q 168 . S IEN=$P(TEXT,";"),SCPER=$P(TEXT,";",2) 169 . I ECXELIG=IEN D 170 . . I SCPER="" S NPCD=$P(TEXT,";",3) Q 171 . . S ECXBG=$S($E(SCPER)="<":0,$E(SCPER)=">":$P(SCPER,">",2)+1,SCPER["-":+SCPER,1:"") 172 . . S ECXEN=$S($E(SCPER)="<":$P(SCPER,"<",2),$E(SCPER)=">":100,SCPER["-":$P(SCPER,"-",2),1:"") 173 . . I ECXSVCP'<ECXBG,ECXSVCP'>ECXEN S NPCD=$P(TEXT,";",3) 174 S ECXNPCD=$G(NPCD) 175 Q ECXNPCD 176 ELGTXT ;Eligibility codes 177 ;;1;>49;10;SC 50-100% 178 ;;2;;20;Aid & Attendance 179 ;;15;;21;Housebound 180 ;;16;;22;Mexican Border War 181 ;;17;;23;WWI 182 ;;18;;24;POW 183 ;;3;40-49;30;SC 40-49% 184 ;;3;30-39;31;SC 30-39% 185 ;;3;20-29;32;SC 20-29% 186 ;;3;10-19;33;SC 10-19% 187 ;;3;<10;34;SC less than 10% 188 ;;4;;40;NSC - VA Pension 189 ;;5;;50;NSC 190 ;;21;;60;Catastrophic Disability 191 ;;12;;101;CHAMPVA 192 ;;13;;102;Collateral of Veteran 193 ;;14;;103;Employee 194 ;;6;;104;Other Federal Agency 195 ;;7;;105;Allied Veteran 196 ;;8;;106;Humanitarian Emergency 197 ;;9;;107;Sharing Agreement 198 ;;10;;108;Reimbursable Insurance 199 ;;19;;109;TRICARE/CHAMPUS 200 ;;22;;25;Purple Heart Recipient 201 ;;END 202 ; 203 CPT(ECXCPT,ECXMOD,ECXQUA) ;Returns a str with CPT code and modifier codes 204 ;Return string is composed of a 5 character CPT code 2 character quantity 205 ;plus up to 5 modifier codes, 2 characters each. 206 ; Variables - 207 ; Input ECXCPT - Pointer value to the CPT file (#81) 208 ; ECXMOD - A string with pointer values to the CPT 209 ; MODIFIER file (#81.3) separated by ";" 210 ; ECXQUA - Number of time this procedure performed 211 ; 212 ; Output: 213 ; CPTMOD - String of up to 17 characters, 5 character CPT 214 ; code 2 character qty plus up to 5 2-character 215 ; code modifiers. 216 ; 217 N CPT,MOD,I,CPTMOD 218 S ECXQUA=$G(ECXQUA,"01"),ECXMOD=$G(ECXMOD) 219 S:$L(ECXQUA)'=2 ECXQUA="0"_ECXQUA 220 S CPT=$$CPT^ICPTCOD(ECXCPT,"") I +CPT=-1 Q "" 221 S CPT=$P(CPT,U,2)_ECXQUA 222 F I=1:1:99 I $P(ECXMOD,";",I)'="" D 223 . S MOD=$$MOD^ICPTMOD($P(ECXMOD,";",I),"I","") 224 . I +MOD>0,$P(MOD,U,2)'="99" S CPT=CPT_$P(MOD,U,2) 225 S CPTMOD=$TR($E(CPT,1,17)," ") 226 Q CPTMOD 227 ; 228 CPTOUT(ECXCPT) ;output transform for CPT code plus modifiers 229 ;input ECXCPT - character string of CPT code plus modifiers (required) 230 ; 231 N J,CPTX,MOD,MODS,MODX,CPTMOD 232 Q:$G(ECXCPT)="" "" 233 S (CPTMOD,MODX)="" 234 S CPTX="("_+$E(ECXCPT,6,7)_") "_$E(ECXCPT,1,5),MODS=$E(ECXCPT,8,17) 235 F J=1:2:9 S MOD=$E(MODS,J,J+1) Q:MOD="" D 236 .I J>1 S MODX=MODX_", "_MOD Q 237 .S MODX=MODX_"-"_MOD 238 S:$L(CPTX)>3 CPTMOD=CPTMOD_CPTX_MODX 239 Q CPTMOD
Note:
See TracChangeset
for help on using the changeset viewer.
