Changeset 623 for WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUTL2.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUTL2.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUTL2.m
r613 r623 1 ECXUTL2 ;ALB/JAP - Utilities for DSS Extracts (cont.) ; 6/12/07 6:38am 2 ;;3.0;DSS EXTRACTS;**8,13,23,24,33,35,39,46,71,84,92,105**;Dec 22, 1997;Build 70 3 ; 4 ECXDEF(ECXHEAD,ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER) ;variables specific to extract from file #727.1 5 ; input 6 ; ECXHEAD = extract header code 7 ; all other formal list parameters passed by reference 8 ; output 9 ; ECXPACK = type field (#7) 10 ; ECXGRP = group field (#9) 11 ; ECXFILE = file number field (#1) 12 ; ECXRTN = routine field (#4) 13 ; ECXPIECE= running piece field (#11) 14 ; ECXVER = dss version 15 N ECXIEN,ECXARR,DIC,DA,DR,DIQ 16 S (ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER)="",ECXIEN=0 17 S ECXIEN=+$O(^ECX(727.1,"C",ECXHEAD,ECXIEN)) 18 I ECXIEN=0 D Q 19 .D MES^XPDUTL(" ") 20 .D MES^XPDUTL(" It appears that you may have a problem with File #727.1 --") 21 .D MES^XPDUTL(" ") 22 .D MES^XPDUTL(" The "_ECHEAD_" Extract is not properly defined.") 23 .D MES^XPDUTL(" ") 24 .D MES^XPDUTL(" Contact National VISTA Support for further assistance.") 25 .D MES^XPDUTL(" ") 26 .I $E(IOST)="C" D 27 ..S SS=22-$Y F JJ=1:1:SS W ! 28 ..S DIR(0)="E" W ! D ^DIR K DIR 29 .W !! 30 S DIC="^ECX(727.1,",DA=ECXIEN,DR=".01;1;4;7;9;11",DIQ="ECXARR" 31 D EN^DIQ1 32 S ECXPACK=ECXARR(727.1,ECXIEN,7) 33 ;if this is an inactive extract type, skip it 34 I ECXPACK["Inactive" D Q 35 .D MES^XPDUTL(" ") 36 .D MES^XPDUTL(" The "_ECHEAD_" Extract is no longer active/valid.") 37 .D MES^XPDUTL(" ") 38 .D MES^XPDUTL(" Contact National VISTA Support for further assistance.") 39 .D MES^XPDUTL(" ") 40 .I $E(IOST)="C" D 41 ..S SS=22-$Y F JJ=1:1:SS W ! 42 ..S DIR(0)="E" W ! D ^DIR K DIR 43 .W !! 44 S ECXGRP=ECXARR(727.1,ECXIEN,9) 45 S ECXFILE=ECXARR(727.1,ECXIEN,1) 46 S ECXRTN="START^"_ECXARR(727.1,ECXIEN,4) 47 S ECXPIECE=ECXARR(727.1,ECXIEN,11) 48 ;version of dss/tsi in Austin as specified by btso 49 S ECXVER=7 50 Q 51 PATDEM(DFN,DT1,PAR,FLG) ; determine patient information 52 ; DFN = 53 ; DT = 54 ; PAR = 55 ; FLG = 56 N DT2,PAT,OK,X 57 D KPATDEM 58 S FLG=$G(FLG),PAR=$S($D(PAR):PAR,1:"1;2;3;4;5;"),DT2=$P(DT1,".") 59 Q:'$$PAT^ECXUTL3(DFN,DT2,PAR,.PAT) 0 60 S ECXMPI=PAT("MPI") 61 I PAR["1" D 62 .S ECXSSN=PAT("SSN"),ECXPNM=PAT("NAME"),ECXDOB=PAT("DOB") 63 .S ECXSEX=PAT("SEX"),ECXREL=PAT("RELIGION"),ECXRACE=PAT("RACE") 64 .S ECXMAR=PAT("MARITAL") 65 .S ECXETH=PAT("ETHNIC"),ECXRC1=PAT("RACE1") 66 I PAR["2" D 67 .S ECXCNTY=PAT("COUNTY"),ECXSTATE=PAT("STATE"),ECXZIP=PAT("ZIP") 68 I PAR["3" D 69 .S ECXPOS=PAT("POS"),ECSC=PAT("SC STAT"),ECXSVC=PAT("SC%") 70 .S ECXVET=PAT("VET"),ECXMEAN=PAT("MEANS"),ECXELIG=PAT("ELIG") 71 .S ECXENRL=PAT("ENROLL LOC") 72 .S ECXERI=PAT("ERI") 73 I PAR["4" S ECXEMP=PAT("EMPLOY") 74 I PAR["5" D 75 .S ECXVIET=PAT("VIETNAM"),ECXAST=PAT("AO STAT"),ECXRST=PAT("IR STAT") 76 .S ECXEST=PAT("EC STAT"),ECXPST=PAT("POW STAT"),ECXPLOC=PAT("POW LOC") 77 .S ECXPHI=PAT("PHI"),ECXMST=PAT("MST STAT"),ECXAOL=PAT("AOL") 78 .S ECXOEF=PAT("ECXOEF"),ECXOEFDT=PAT("ECXOEFDT") 79 I PAR["6" D 80 .S (ECXPAYOR,ECXSAI)="" D VISN19(DFN,.ECXPAYOR,.ECXSAI) 81 I FLG'[3 D 82 .S X=$$PRIMARY(DFN,DT2),ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3) 83 .S ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6) 84 .S ECASNPI=$P(X,U,7) 85 I FLG'[2 D 86 .S ECXINP=$$INP^ECXUTL2(DFN,DT1),ECXA=$P(ECXINP,U),ECXMN=$P(ECXINP,U,2) 87 .S ECXTS=$P(ECXINP,U,3),ECXDOM=$P(ECXINP,U,10),ECXADMDT=$P(ECXINP,U,4) 88 I FLG'[1 S X=$$ENROLLM(DFN) 89 Q 1 90 ; 91 KPATDEM ; 92 K ECXADMDT,ECAO,ECASNPI,ECASPR,ECCLAS,ECCLAS2,ECENV,ECPTNPI,ECPTPR,ECPTTM 93 K ECRE,ECSC,ECXA,ECXAST,ECXCAT,ECXCNTY,ECXEST,ECXENRL,ECXDOB 94 K ECXDOM,ECXELIG,ECXINP,ECXMPI,ECXMN,ECXNM,ECXPHI,ECXPLOC,ECXMEAN,ECXMST 95 K ECXPAYOR,ECXPNM,ECXPOS,ECXPRIOR,ECXPST,ECXRACE,ECXREL,ECXRST,ECXSAI 96 K ECXSEX,ECXSSN,ECXSTAT,ECXSTATE,ECXSVC,ECXTS,ECXVIET,ECXZIP,VA,VAERR 97 K ECXSBGRP 98 Q 99 ENROLLM(DFN,RNDT) ;determines enrollment status, category, priority 100 ;and user enrollee status 101 ; input 102 ; DFN = IEN from Patient file (Required) 103 ; RNDT = Extract Run Date 104 ; output 105 ; ECXSTAT = Enrollment status 106 ; ECXPRIOR = Enrollment priority 107 ; ECXCAT = Enrollment priority 108 ; ECXSBGRP = Enrollment subgroup 109 ; ECXUESTA = User enrollee 110 ; return value 0 if no data found, 1 if data found 111 N CAT,PRIOR,STAT,X,X1,X2,X3,ENRIEN,ENR,FL,SBGRP 112 S (ECXCAT,ECXPRIOR,ECXSTAT,ECXSBGRP,ECXEUSTA)="" 113 I $G(DFN)="" Q 0 114 ;User enrollee status, if current or future date set to 'U' 115 ;DBIA #3989 116 S ECXUESTA=$S($$UESTAT^EASUER(DFN):"U",1:"") 117 ;Patient type 118 S ECXPTYPE=$$TYPE^ECXUTL5(DFN) 119 ;Combat Veteran Status DBIA #4156 120 S X3=$$CVEDT^ECXUTL5(DFN,$S($G(ECD):ECD,$G(ECXDATE):ECXDATE,1:DT)) 121 ;enrollment priority DBIA 122 S STAT=$$STATUS^DGENA(DFN),PRIOR=$$PRIORITY^DGENA(DFN) 123 S CAT=$$CATEGORY^DGENA4(DFN,STAT),SBGRP=$$ENRSBGRP^DGENA4(DFN) 124 ;find current enrollment when status=2 or 19 125 I "^2^19^"[("^"_STAT_"^") S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT,ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") Q 1 126 ;find previous enrollment 127 S ENRIEN=$$FINDCUR^DGENA(DFN) I ENRIEN="" Q 0 128 I $G(RNDT)="" D NOW^%DTC S RNDT=X 129 S RNDT=($E(RNDT,1,3)-1)_$E(RNDT,4,7),FL=0 130 F S ENRIEN=$$FINDPRI^DGENA(ENRIEN) Q:'ENRIEN D Q:FL 131 . S ENR=$$GET^DGENA(ENRIEN,.ENR) 132 . I "^2^19^"[("^"_ENR("STATUS")_"^"),ENR("EFFDATE")>RNDT D 133 . . S ECXSTAT=ENR("STATUS"),ECXPRIOR=PRIOR,FL=1 134 . . S ECXCAT=$$CATEGORY^DGENA4(DFN,ECXSTAT) 135 . . S ECXSBGRP=$$ENRSBGRP^DGENA4(DFN) 136 . . S ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") 137 I FL Q 1 138 ;no enrollment status found =2 or 19 139 S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT,ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") 140 Q 1 141 PRIMARY(ECXDFN,ECXDATE,ECXPREFX) ;determine patient's pc team and pc provider 142 ; input 143 ; ECXDFN = file #2 ien (required) 144 ; ECXDATE = date of interest (required) 145 ; ECXPREFX = prefix for provider data (optional) 146 ; defaults to "2" if not specified otherwise 147 ; output 148 ; ECXPRIME = pc team ien^prefix_pc provider ien^pc provider person 149 ;class^pc provider npi^prefix_assoc pc provider ien^assoc pc provider 150 ;person class^assoc pc provider npi 151 N ECPTTM,ECPTPR,ECCLAS,ECPRIME,ECASPR,ECCLAS2 152 S:'$D(ECXPREFX) ECXPREFX=2 S:(+ECXPREFX=0) ECXPREFX=2 153 ;get pc team data 154 S ECPTTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDATE) S:ECPTTM=0 ECPTTM="" 155 ;get primary pc provider data 156 S ECPTPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDATE) 157 S ECCLAS="" I ECPTPR>0 S ECCLAS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE) 158 N ECXUSRTN S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECPTPR,ECXDATE) 159 S:+ECXUSRTN'>0 ECXUSRTN="" S ECPTNPI=$P(ECXUSRTN,U) 160 S:ECPTPR=0 ECPTPR="" S:ECPTPR]"" ECPTPR=ECXPREFX_ECPTPR 161 ;assoc pc provider call ok if routine scapmca from patch177 is present 162 S ECASPR="" 163 S X="SCAPMCA" X ^%ZOSF("TEST") I $T D 164 .S ECASPR=+$$OUTPTAP^SDUTL3(ECXDFN,ECXDATE) 165 S ECCLAS2="" I ECASPR>0 S ECCLAS2=$$PRVCLASS^ECXUTL(ECASPR,ECXDATE) 166 N ECXUSRTN S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECASPR,ECXDATE) 167 S:+ECXUSRTN'>0 ECXUSRTN="" S ECASNPI=$P(ECXUSRTN,U) 168 S:ECASPR=0 ECASPR="" S:ECASPR]"" ECASPR=ECXPREFX_ECASPR 169 ;assemble 170 S ECXPRIME=ECPTTM_U_ECPTPR_U_ECCLAS_U_ECPTNPI_U_ECASPR_U_ECCLAS2_U_ECASNPI 171 Q ECXPRIME 172 INP(ECXDFN,ECXDATE) ; check for inpatient status 173 ; input 174 ; ECXDFN = file #2 ien (required) 175 ; ECXDATE = date of interest (required) 176 ; output 177 ; ECXINP = patient status^movment # (file #405 ien) 178 ; current treat. spec. (file #42.4 ien)^admission date/time^ 179 ; current ward (file #42 ien)^discharge date/time^ 180 ; ward provider^attending phys.^ward (file #44 ien);facility 181 ; (file #40.8 ien);dss dept^dom 182 ; where patient status = I for inpatient 183 ; = O for outpatient 184 N DFN,DSSDEPT,ECA,ECADM,ECMN,ECTS,ECWARD,ECDC,ECXINP,ECXPRO 185 N ECXATP,ECXDD,ECXDOM,ECXPROF,ECXPWP,ECXWW,FAC,VAIP,WRD,ECXPWPPC 186 N ECXATPPC 187 D FIELD^DID(405,.19,,"SPECIFIER","ECXDD") 188 S ECXPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD 189 ;- Inpat/outpat indicator (ECA) initially set to "O" (outpatient) 190 S DFN=ECXDFN,ECA="O" 191 S (DSSDEPT,ECMN,ECTS,ECADM,ECWARD,ECDC,ECXATP,ECXPWP,ECXWW,WRD,FAC,ECXPWPPC,ECXATPPC)="" 192 S VAIP("D")=ECXDATE D IN5^VADPT 193 S ECMN=$G(VAIP(1)) 194 I ECMN D 195 .S ECTS=+$P($G(^DIC(45.7,+VAIP(8),0)),U,2) S:ECTS=0 ECTS="" 196 .;- Get inpat/outpat indicator 197 .S ECA=$$INOUTP^ECXUTL4(ECTS) 198 .S ECADM=+$G(VAIP(13,1)) S:ECADM=0 ECADM="" 199 .S ECWARD=+$G(VAIP(5)) S:ECWARD=0 ECWARD="" 200 .I ECWARD D 201 ..S WRD=+$P($G(^DIC(42,+ECWARD,44)),U) 202 ..S FAC=$P($G(^DIC(42,+ECWARD,0)),U,11) 203 ..S DSSDEPT=$P($G(^ECX(727.4,ECWARD,0)),U,2) 204 .S ECXWW=WRD_";"_FAC_";"_DSSDEPT,ECDC=+$G(VAIP(17,1)) S:ECDC=0 ECDC="" 205 .S ECXPWP=+VAIP(7) S:ECXPWP=0 ECXPWP="" 206 .S ECXATP=+VAIP(18) S:ECXATP=0 ECXATP="" 207 .S ECXPWPPC=$$PRVCLASS^ECXUTL(ECXPWP,ECADM) 208 .S ECXATPPC=$$PRVCLASS^ECXUTL(ECXATP,ECADM) 209 .;prefix file #200 iens 210 .S:ECXPWP ECXPWP=ECXPROF_ECXPWP S:ECXATP ECXATP=ECXPROF_ECXATP 211 S ECXDOM=$P($G(^ECX(727.831,+ECTS,0)),U,2) 212 S ECXINP=ECA_U_ECMN_U_ECTS_U_ECADM_U_ECWARD_U_ECDC_U_ECXPWP_U_ECXATP_U_ECXWW_U_ECXDOM_U_ECXPWPPC_U_ECXATPPC 213 Q ECXINP 214 VISN19(ECXDFN,ECXPAYOR,ECXSAI) ;visn 19 sharing agreement data 215 ; input ECXDFN = patient file ien 216 ; output ECXPAYOR, ECXSAI (passed by reference) 217 N JJ,ALIAS,INSUR,DIC,DIQ,DA,DR,ECXARY,ECXERR,ECXDA 218 S (ECXPAYOR,ECXSAI)="" 219 D GETS^DIQ(2,ECXDFN,"1*,","I","ECXARY","ECXERR") 220 I $D(ECXERR) Q 221 S JJ=0 F S JJ=$O(ECXARY(2.01,JJ)) Q:JJ="" D I ECXPAYOR]"" Q 222 . S ALIAS=$G(ECXARY(2.01,JJ,.01,"I")) 223 . S ECXPAYOR=$S(ALIAS="SHARING AGREEMENT":"A",ALIAS="TRICARE":"B",ALIAS="CAT C":"C",ALIAS="CATEGORY C":"C",ALIAS="CHAMPVA":"D",ALIAS="CHAMPUS":"E",1:"") 224 . W !,$G(CNT)+1 225 . W !,"The value of ECXPAYOR is: ",ECXPAYOR 226 ;K ECXARY,ECXERR 227 I ECXPAYOR]"" D GETS^DIQ(2,ECXDFN,".3121*,","I","ECXARY","ECXERR") D 228 . I $D(ECXERR) Q 229 . S JJ=0,ECXDA=$O(ECXARY(2.312,JJ)) I ECXDA="" Q 230 . S DA=$G(ECXARY(2.312,ECXDA,.01,"I")) I DA="" Q 231 . S INSUR=$$GET1^DIQ(36,DA,".01","I","","ECXERR") 232 . I '$D(ECXERR) S ECXSAI=$E(ECXARY(2.312,ECXDA,.01,"I"),1,11) 233 Q 1 ECXUTL2 ;ALB/JAP - Utilities for DSS Extracts (cont.) ; 11/2/06 9:03am 2 ;;3.0;DSS EXTRACTS;**8,13,23,24,33,35,39,46,71,84,92**;Dec 22, 1997;Build 30 3 ; 4 ECXDEF(ECXHEAD,ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER) ;variables specific to extract from file #727.1 5 ; input 6 ; ECXHEAD = extract header code 7 ; all other formal list parameters passed by reference 8 ; output 9 ; ECXPACK = type field (#7) 10 ; ECXGRP = group field (#9) 11 ; ECXFILE = file number field (#1) 12 ; ECXRTN = routine field (#4) 13 ; ECXPIECE= running piece field (#11) 14 ; ECXVER = dss version 15 ; 16 N ECXIEN,ECXARR,DIC,DA,DR,DIQ 17 S (ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER)="",ECXIEN=0 18 S ECXIEN=+$O(^ECX(727.1,"C",ECXHEAD,ECXIEN)) 19 I ECXIEN=0 D Q 20 .D MES^XPDUTL(" ") 21 .D MES^XPDUTL(" It appears that you may have a problem with File #727.1 --") 22 .D MES^XPDUTL(" ") 23 .D MES^XPDUTL(" The "_ECHEAD_" Extract is not properly defined.") 24 .D MES^XPDUTL(" ") 25 .D MES^XPDUTL(" Contact National VISTA Support for further assistance.") 26 .D MES^XPDUTL(" ") 27 .I $E(IOST)="C" D 28 ..S SS=22-$Y F JJ=1:1:SS W ! 29 ..S DIR(0)="E" W ! D ^DIR K DIR 30 .W !! 31 S DIC="^ECX(727.1,",DA=ECXIEN,DR=".01;1;4;7;9;11",DIQ="ECXARR" 32 D EN^DIQ1 33 S ECXPACK=ECXARR(727.1,ECXIEN,7) 34 ;if this is an inactive extract type, skip it 35 I ECXPACK["Inactive" D Q 36 .D MES^XPDUTL(" ") 37 .D MES^XPDUTL(" The "_ECHEAD_" Extract is no longer active/valid.") 38 .D MES^XPDUTL(" ") 39 .D MES^XPDUTL(" Contact National VISTA Support for further assistance.") 40 .D MES^XPDUTL(" ") 41 .I $E(IOST)="C" D 42 ..S SS=22-$Y F JJ=1:1:SS W ! 43 ..S DIR(0)="E" W ! D ^DIR K DIR 44 .W !! 45 S ECXGRP=ECXARR(727.1,ECXIEN,9) 46 S ECXFILE=ECXARR(727.1,ECXIEN,1) 47 S ECXRTN="START^"_ECXARR(727.1,ECXIEN,4) 48 S ECXPIECE=ECXARR(727.1,ECXIEN,11) 49 ;version of dss/tsi in Austin as specified by btso 50 S ECXVER=7 51 Q 52 ; 53 PATDEM(DFN,DT1,PAR,FLG) ; determine patient information 54 ; DFN = 55 ; DT = 56 ; PAR = 57 ; FLG = 58 N DT2,PAT,OK,X 59 D KPATDEM 60 S FLG=$G(FLG),PAR=$S($D(PAR):PAR,1:"1;2;3;4;5;"),DT2=$P(DT1,".") 61 Q:'$$PAT^ECXUTL3(DFN,DT2,PAR,.PAT) 0 62 S ECXMPI=PAT("MPI") 63 I PAR["1" D 64 .S ECXSSN=PAT("SSN"),ECXPNM=PAT("NAME"),ECXDOB=PAT("DOB") 65 .S ECXSEX=PAT("SEX"),ECXREL=PAT("RELIGION"),ECXRACE=PAT("RACE") 66 .S ECXMAR=PAT("MARITAL") 67 .S ECXETH=PAT("ETHNIC"),ECXRC1=PAT("RACE1") 68 I PAR["2" D 69 .S ECXCNTY=PAT("COUNTY"),ECXSTATE=PAT("STATE"),ECXZIP=PAT("ZIP") 70 I PAR["3" D 71 .S ECXPOS=PAT("POS"),ECSC=PAT("SC STAT"),ECXSVC=PAT("SC%") 72 .S ECXVET=PAT("VET"),ECXMEAN=PAT("MEANS"),ECXELIG=PAT("ELIG") 73 .S ECXENRL=PAT("ENROLL LOC") 74 .S ECXERI=PAT("ERI") 75 I PAR["4" S ECXEMP=PAT("EMPLOY") 76 I PAR["5" D 77 .S ECXVIET=PAT("VIETNAM"),ECXAST=PAT("AO STAT"),ECXRST=PAT("IR STAT") 78 .S ECXEST=PAT("EC STAT"),ECXPST=PAT("POW STAT"),ECXPLOC=PAT("POW LOC") 79 .S ECXPHI=PAT("PHI"),ECXMST=PAT("MST STAT"),ECXAOL=PAT("AOL") 80 I PAR["6" D 81 .S (ECXPAYOR,ECXSAI)="" D VISN19(DFN,.ECXPAYOR,.ECXSAI) 82 I FLG'[3 D 83 .S X=$$PRIMARY(DFN,DT2),ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3) 84 .S ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6) 85 .S ECASNPI=$P(X,U,7) 86 I FLG'[2 D 87 .S ECXINP=$$INP^ECXUTL2(DFN,DT1),ECXA=$P(ECXINP,U),ECXMN=$P(ECXINP,U,2) 88 .S ECXTS=$P(ECXINP,U,3),ECXDOM=$P(ECXINP,U,10),ECXADMDT=$P(ECXINP,U,4) 89 I FLG'[1 S X=$$ENROLLM(DFN) 90 Q 1 91 ; 92 KPATDEM ; 93 K ECXADMDT,ECAO,ECASNPI,ECASPR,ECCLAS,ECCLAS2,ECENV,ECPTNPI,ECPTPR,ECPTTM 94 K ECRE,ECSC,ECXA,ECXAST,ECXCAT,ECXCNTY,ECXEST,ECXENRL,ECXDOB 95 K ECXDOM,ECXELIG,ECXINP,ECXMPI,ECXMN,ECXNM,ECXPHI,ECXPLOC,ECXMEAN,ECXMST 96 K ECXPAYOR,ECXPNM,ECXPOS,ECXPRIOR,ECXPST,ECXRACE,ECXREL,ECXRST,ECXSAI 97 K ECXSEX,ECXSSN,ECXSTAT,ECXSTATE,ECXSVC,ECXTS,ECXVIET,ECXZIP,VA,VAERR 98 K ECXSBGRP 99 Q 100 ; 101 ENROLLM(DFN,RNDT) ;determines enrollment status, category, priority 102 ;and user enrollee status 103 ; input 104 ; DFN = IEN from Patient file (Required) 105 ; RNDT = Extract Run Date 106 ; output 107 ; ECXSTAT = Enrollment status 108 ; ECXPRIOR = Enrollment priority 109 ; ECXCAT = Enrollment priority 110 ; ECXSBGRP = Enrollment subgroup 111 ; ECXUESTA = User enrollee 112 ; return value 0 if no data found, 1 if data found 113 ; 114 N CAT,PRIOR,STAT,X,X1,X2,X3,ENRIEN,ENR,FL,SBGRP 115 S (ECXCAT,ECXPRIOR,ECXSTAT,ECXSBGRP,ECXEUSTA)="" 116 I $G(DFN)="" Q 0 117 ;User enrollee status, if current or future date set to 'U' 118 ;DBIA #3989 119 S ECXUESTA=$S($$UESTAT^EASUER(DFN):"U",1:"") 120 ;Patient type 121 S ECXPTYPE=$$TYPE^ECXUTL5(DFN) 122 ;Combat Veteran Status DBIA #4156 123 S X3=$$CVEDT^ECXUTL5(DFN,$S($G(ECD):ECD,$G(ECXDATE):ECXDATE,1:DT)) 124 ;enrollment priority DBIA 125 S STAT=$$STATUS^DGENA(DFN),PRIOR=$$PRIORITY^DGENA(DFN) 126 S CAT=$$CATEGORY^DGENA4(DFN,STAT),SBGRP=$$ENRSBGRP^DGENA4(DFN) 127 ;find current enrollment when status=2 or 19 128 I "^2^19^"[("^"_STAT_"^") S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT,ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") Q 1 129 ;find previous enrollment 130 S ENRIEN=$$FINDCUR^DGENA(DFN) I ENRIEN="" Q 0 131 I $G(RNDT)="" D NOW^%DTC S RNDT=X 132 S RNDT=($E(RNDT,1,3)-1)_$E(RNDT,4,7),FL=0 133 F S ENRIEN=$$FINDPRI^DGENA(ENRIEN) Q:'ENRIEN D Q:FL 134 . S ENR=$$GET^DGENA(ENRIEN,.ENR) 135 . I "^2^19^"[("^"_ENR("STATUS")_"^"),ENR("EFFDATE")>RNDT D 136 . . S ECXSTAT=ENR("STATUS"),ECXPRIOR=PRIOR,FL=1 137 . . S ECXCAT=$$CATEGORY^DGENA4(DFN,ECXSTAT) 138 . . S ECXSBGRP=$$ENRSBGRP^DGENA4(DFN) 139 . . S ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") 140 I FL Q 1 141 ;no enrollment status found =2 or 19 142 S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT,ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") 143 Q 1 144 ; 145 PRIMARY(ECXDFN,ECXDATE,ECXPREFX) ;determine patient's pc team and pc provider 146 ; input 147 ; ECXDFN = file #2 ien (required) 148 ; ECXDATE = date of interest (required) 149 ; ECXPREFX = prefix for provider data (optional) 150 ; defaults to "2" if not specified otherwise 151 ; output 152 ; ECXPRIME = pc team ien^prefix_pc provider ien^pc provider person class^pc provider npi 153 ; ^prefix_assoc pc provider ien^assoc pc provider person class^assoc pc provider npi 154 ; 155 N ECPTTM,ECPTPR,ECCLAS,ECPRIME,ECASPR,ECCLAS2 156 S:'$D(ECXPREFX) ECXPREFX=2 S:(+ECXPREFX=0) ECXPREFX=2 157 ;get pc team data 158 S ECPTTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDATE) S:ECPTTM=0 ECPTTM="" 159 ;get primary pc provider data 160 S ECPTPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDATE) 161 S ECCLAS="" I ECPTPR>0 S ECCLAS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE) 162 S:ECPTPR=0 ECPTPR="" S:ECPTPR]"" ECPTPR=ECXPREFX_ECPTPR 163 S ECPTNPI="" 164 ;assoc pc provider call ok if routine scapmca from patch177 is present 165 S ECASPR="" 166 S X="SCAPMCA" X ^%ZOSF("TEST") I $T D 167 .S ECASPR=+$$OUTPTAP^SDUTL3(ECXDFN,ECXDATE) 168 S ECCLAS2="" I ECASPR>0 S ECCLAS2=$$PRVCLASS^ECXUTL(ECASPR,ECXDATE) 169 S:ECASPR=0 ECASPR="" S:ECASPR]"" ECASPR=ECXPREFX_ECASPR 170 S ECASNPI="" 171 ;assemble 172 S ECXPRIME=ECPTTM_U_ECPTPR_U_ECCLAS_U_ECPTNPI_U_ECASPR_U_ECCLAS2_U_ECASNPI 173 Q ECXPRIME 174 ; 175 INP(ECXDFN,ECXDATE) ; check for inpatient status 176 ; input 177 ; ECXDFN = file #2 ien (required) 178 ; ECXDATE = date of interest (required) 179 ; output 180 ; ECXINP = patient status^movment # (file #405 ien) 181 ; current treat. spec. (file #42.4 ien)^admission date/time^ 182 ; current ward (file #42 ien)^discharge date/time^ 183 ; ward provider^attending phys.^ward (file #44 ien);facility 184 ; (file #40.8 ien);dss dept^dom 185 ; where patient status = I for inpatient 186 ; = O for outpatient 187 ; 188 N DFN,DSSDEPT,ECA,ECADM,ECMN,ECTS,ECWARD,ECDC,ECXINP,ECXPRO 189 N ECXATP,ECXDD,ECXDOM,ECXPROF,ECXPWP,ECXWW,FAC,VAIP,WRD,ECXPWPPC 190 N ECXATPPC 191 D FIELD^DID(405,.19,,"SPECIFIER","ECXDD") 192 S ECXPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD 193 ; 194 ;- Inpat/outpat indicator (ECA) initially set to "O" (outpatient) 195 S DFN=ECXDFN,ECA="O" 196 S (DSSDEPT,ECMN,ECTS,ECADM,ECWARD,ECDC,ECXATP,ECXPWP,ECXWW,WRD,FAC,ECXPWPPC,ECXATPPC)="" 197 S VAIP("D")=ECXDATE D IN5^VADPT 198 S ECMN=$G(VAIP(1)) 199 I ECMN D 200 .S ECTS=+$P($G(^DIC(45.7,+VAIP(8),0)),U,2) S:ECTS=0 ECTS="" 201 .; 202 .;- Get inpat/outpat indicator 203 .S ECA=$$INOUTP^ECXUTL4(ECTS) 204 .S ECADM=+$G(VAIP(13,1)) S:ECADM=0 ECADM="" 205 .S ECWARD=+$G(VAIP(5)) S:ECWARD=0 ECWARD="" 206 .I ECWARD D 207 ..S WRD=+$P($G(^DIC(42,+ECWARD,44)),U) 208 ..S FAC=$P($G(^DIC(42,+ECWARD,0)),U,11) 209 ..S DSSDEPT=$P($G(^ECX(727.4,ECWARD,0)),U,2) 210 .S ECXWW=WRD_";"_FAC_";"_DSSDEPT,ECDC=+$G(VAIP(17,1)) S:ECDC=0 ECDC="" 211 .S ECXPWP=+VAIP(7) S:ECXPWP=0 ECXPWP="" 212 .S ECXATP=+VAIP(18) S:ECXATP=0 ECXATP="" 213 .S ECXPWPPC=$$PRVCLASS^ECXUTL(ECXPWP,ECADM) 214 .S ECXATPPC=$$PRVCLASS^ECXUTL(ECXATP,ECADM) 215 .;prefix file #200 iens 216 .S:ECXPWP ECXPWP=ECXPROF_ECXPWP S:ECXATP ECXATP=ECXPROF_ECXATP 217 S ECXDOM=$P($G(^ECX(727.831,+ECTS,0)),U,2) 218 S ECXINP=ECA_U_ECMN_U_ECTS_U_ECADM_U_ECWARD_U_ECDC_U_ECXPWP_U_ECXATP_U_ECXWW_U_ECXDOM_U_ECXPWPPC_U_ECXATPPC 219 Q ECXINP 220 ; 221 VISN19(ECXDFN,ECXPAYOR,ECXSAI) ;visn 19 sharing agreement data 222 ; input ECXDFN = patient file ien 223 ; output ECXPAYOR, ECXSAI (passed by reference) 224 ; 225 N JJ,ALIAS,INSUR,DIC,DIQ,DA,DR,ECXARY,ECXERR,ECXDA 226 S (ECXPAYOR,ECXSAI)="" 227 D GETS^DIQ(2,ECXDFN,"1*,","I","ECXARY","ECXERR") 228 I $D(ECXERR) Q 229 S JJ=0 F S JJ=$O(ECXARY(2.01,JJ)) Q:JJ="" D I ECXPAYOR]"" Q 230 . S ALIAS=$G(ECXARY(2.01,JJ,.01,"I")) 231 . S ECXPAYOR=$S(ALIAS="SHARING AGREEMENT":"A",ALIAS="TRICARE":"B",ALIAS="CAT C":"C",ALIAS="CATEGORY C":"C",ALIAS="CHAMPVA":"D",ALIAS="CHAMPUS":"E",1:"") 232 . W !,$G(CNT)+1 233 . W !,"The value of ECXPAYOR is: ",ECXPAYOR 234 ;K ECXARY,ECXERR 235 I ECXPAYOR]"" D GETS^DIQ(2,ECXDFN,".3121*,","I","ECXARY","ECXERR") D 236 . W !,"This is a test" 237 . I $D(ECXERR) Q 238 . S JJ=0,ECXDA=$O(ECXARY(2.312,JJ)) I ECXDA="" Q 239 . S DA=$G(ECXARY(2.312,ECXDA,.01,"I")) I DA="" Q 240 . S INSUR=$$GET1^DIQ(36,DA,".01","I","","ECXERR") 241 . I '$D(ECXERR) S ECXSAI=$E(ECXARY(2.312,ECXDA,.01,"I"),1,11) 242 Q
Note:
See TracChangeset
for help on using the changeset viewer.
