Changeset 623 for WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXQSR.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXQSR.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXQSR.m
r613 r623 1 ECXQSR ;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 3 BEG ;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 10 START ;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 19 QINST ;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 29 UPDATE ;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 145 SETUP ;Set required input for ECXTRAC 146 S ECHEAD="ECQ" 147 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 148 Q 149 QUE ;Entry point for the background requeuing handled by ECXTAUTO. 150 D SETUP,QUE^ECXTAUTO,^ECXKILL Q 1 ECXQSR ;ALB/JAP,BIR/PTD-DSS QUASAR Extract ; 04/16/07 8:58am 2 ;;3.0;DSS EXTRACTS;**11,8,13,26,24,34,33,35,39,43,46,49,64,71,84,92,106**;Dec 22, 1997;Build 1 3 BEG ;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 10 START ;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 19 QINST ;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 29 UPDATE ;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 ECHL="",ECXDIV=$P($G(^ACK(509850.6,ECDA,5)),U),ECSTOP=$P(EC2NODE,U) 38 S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV) ; Get Production Division 39 Q:ECSTOP="" 40 S (ECHLS,ECHL2S)="000",ECAC=$P($G(ECZNODE),U,6) 41 I ECAC D 42 .S ECHL=+$P($G(^SC(ECAC,0)),U,7),ECHL2=+$P($G(^(0)),U,18) I ECHL D 43 ..S ECHLS=$P($G(^DIC(40.7,+ECHL,0)),U,2),ECHL2S=$P($G(^DIC(40.7,+ECHL2,0)),U,2) 44 ..S ECHLS=$$RJ^XLFSTR(ECHLS,3,0),ECHL2S=$$RJ^XLFSTR(ECHL2S,3,0) 45 S ECDSS=ECHLS_ECHL2S 46 I ECXLOGIC>2003 D 47 .I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECDSS=$$TSMAP^ECXUTL4(ECXTS) 48 S ECDU=$S(ECSTOP["A":$P(ECLINK,U),ECSTOP["S":$P(ECLINK,U,2),1:"") 49 Q:'ECDU 50 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) 51 Q:'$O(^ACK(509850.6,ECDA,3,0)) 52 ;Create local array of procedure codes and # of times each procedure 53 ; was performed. 54 F I=1:1:4 S @("ECXICD9"_I)="" 55 S (ECDIA,ECXPPC,ECXPRV1,ECXPRV2,ECXPRV3,ECUN1NPI)="" 56 ;if QUASAR v2 57 I +ECXQV=2 D 58 .S ECXPRV1=$P(EC2NODE,U,7),ECXPRV2=$P(EC2NODE,U,3),ECXPRV3=$P(EC2NODE,U,5),ECPN=0 59 .F S ECPN=$O(^ACK(509850.6,ECDA,3,ECPN)) Q:'ECPN D 60 ..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) 61 ..I ECXCPT]"" D 62 ...I '$D(LOC(ECXCPT)) S LOC(ECXCPT)=0_U_ECXPRV1 63 ...S $P(LOC(ECXCPT),U)=$P(LOC(ECXCPT),U)+1 64 .S ECIEN=$O(^ACK(509850.6,ECDA,1,0)),ECDIA=$P($G(^ICD9(+$G(^ACK(509850.6,ECDA,1,ECIEN,0)),0)),U) 65 .F I=1:1:4 S ECIEN=$O(^ACK(509850.6,ECDA,1,ECIEN)) Q:'+ECIEN D 66 ..S @("ECXICD9"_I)=$P($G(^ICD9(+$P(^ACK(509850.6,ECDA,1,ECIEN,0),U),0)),U) 67 ;if QUASAR v3 68 I +ECXQV=3 D 69 .N CPT,DIA,I,J,MOD,MOD1,P,STR,VOL,ECTP,ARY,ECP,ECPN 70 .S ECXPRV2=$G(^ACK(509850.6,ECDA,2.7,1,0)),ECXPRV3=$G(^ACK(509850.6,ECDA,2.7,2,0)) 71 .S ECPN=0 F S ECPN=$O(^ACK(509850.6,ECDA,3,ECPN)) Q:'ECPN D 72 ..S CPT=^ACK(509850.6,ECDA,3,ECPN,0),ECXCPT=$P(CPT,U),ECTP=+$P(CPT,U,5),ECV=1,ECP="" 73 ..Q:ECXCPT="" 74 ..I ECTP D 75 ...S CPT=$G(^ACK(509850.6,ECDA,7,ECTP,0)),ECP=$P(CPT,U) 76 ...S ECP=$S(ECP<90000:$P($G(^EC(725,+ECP,0)),U,2)_"N",1:$P($G(^EC(725,+ECP,0)),U,2)_"L") 77 ...S VOL=+$P(CPT,U,2),ECXPRV1=$P(CPT,U,3) 78 ..I 'ECTP S VOL=+$P(CPT,U,3),ECXPRV1=$P(CPT,U,4) 79 ..S ECXCPT=$E($$CPT^ECXUTL3(ECXCPT),1,5),ECXMOD="",MOD=0 80 ..F S MOD=$O(^ACK(509850.6,ECDA,3,ECPN,1,MOD)) Q:'MOD D 81 ...S MOD1=+^ACK(509850.6,ECDA,3,ECPN,1,MOD,0) D:MOD1 82 ....S ECXMOD=ECXMOD_MOD1_";" 83 ..F I=1:1:$L(ECXMOD,";") I $G(ARY(ECXCPT))'[$P(ECXMOD,";",I) D 84 ...S ARY(ECXCPT)=$G(ARY(ECXCPT))_$P(ECXMOD,";",I)_";" 85 ..S:VOL ECV=VOL 86 ..S ECV=ECV+$G(LOC(ECXCPT)),LOC(ECXCPT)=ECV_U_ECXPRV1_U_ECP 87 .S ECIEN=0 F S ECIEN=$O(^ACK(509850.6,ECDA,1,ECIEN)) Q:'ECIEN D 88 ..S DIA=^ACK(509850.6,ECDA,1,ECIEN,0),P=$P(DIA,U,2),P=$S(P=1:"P",1:"S") 89 ..S CNT=$G(STR(P))+1,STR(P,CNT)=$P($G(^ICD9(+DIA,0)),U),STR(P)=CNT 90 .S ECDIA=$G(STR("P",1)) 91 .F I=1:1:4 Q:'$D(STR("P",I+1)) S @("ECXICD9"_I)=STR("P",I) 92 .S:ECDIA="" ECDIA=$G(STR("S",1)),I=2 93 .F J=I:1:4 Q:'$D(STR("S",J)) S @("ECXICD9"_J)=STR("S",J) 94 Q:('$D(LOC))!('$O(^ACK(509850.6,ECDA,1,0))) 95 ;- Ord Div, Contract St/End Dates, Contract Type placeholders for FY2002 96 S (ECXODIV,ECXCSDT,ECXCEDT,ECXCTYP)="" 97 ;set up Provider Person class 98 S (ECXCPT,ECXPPC1,ECXPPC2,ECXPPC3)="" 99 S:ECXPRV2'="" ECXPPC2=$$PRVCLASS^ECXUTL(ECXPRV2,ECD) 100 S:ECXPRV3'="" ECXPPC3=$$PRVCLASS^ECXUTL(ECXPRV3,ECD) 101 N DA,DIC,DIK,DR,FILEN,DIQ,XVAR,II,DI 102 F II=2,3 S XVAR="ECXPRV"_II I @XVAR'="" D 103 .S DA=@XVAR,(DIC,FILEN)=509850.3,DR=".01",DIQ="ECXQSR",DIQ(0)="I" D EN^DIQ1 104 .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 105 ; -Observation Patient Indicator (yes/no) 106 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECDSS) 107 ; -CNH status (YES/NO) 108 S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) 109 ;get encounter classification 110 S (ECXAO,ECXECE,ECXIR,ECXMIL,ECXHNC)="",ECXVISIT=$P($G(^ACK(509850.6,ECDA,6)),U,3) 111 I ECXVISIT'="" D 112 .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q 113 .S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE")) 114 .S ECXIR=$G(ECXVIST("IR")),ECXMIL=$G(ECXVIST("MST")),ECXHNC=$G(ECXVIST("HNC")) 115 ; -Head and Neck Cancer Indicator 116 S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) 117 ;get enrollment data (category, status and priority) 118 I $$ENROLLM^ECXUTL2(ECXDFN) 119 ; -Get national patient record flag Indicator if exist 120 D NPRF^ECXUTL5 121 ; -If no encounter number don't file record 122 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECDT,ECXTS,ECXOBS,ECHEAD,ECDSS,) 123 Q:ECXENC="" 124 ;Loop through array of unique procedures. Create record in ECODE. 125 S CPT="" F S CPT=$O(LOC(CPT)) Q:CPT="" D 126 .S ECV=+$P(LOC(CPT),U),ECXCPT=$$CPT^ECXUTL3(CPT,$G(ARY(CPT)),ECV) 127 .S ECXPRV1=$P(LOC(CPT),U,2) 128 .S:ECXPRV1'="" ECXPPC1=$$PRVCLASS^ECXUTL(ECXPRV1,ECD),ECXPRV1=2_ECXPRV1 129 .S ECP=$P(LOC(CPT),U,3) I ECP="" S ECP=$$CPT^ECXUTL3(CPT,"",ECV) 130 .D FILE 131 K CPT,LOC 132 Q 133 FILE ;file record in #727.825 134 ;node0 135 ;inst^dfn ECXDFN^ssn ECXSSN^name ECXPNM^i/o status ECXA^day ECDAY^ 136 ;DSS unit ECDU^^category ECPTTM^procedure ECP^volume ECV^cost center^ 137 ;ordering sec ^section^provider ECXPRV1^ECXPPC1^ECXPRV2^ECXPPC2^ECXPRV3^ 138 ;ECXPPC3^mov # ECXMN^treat spec ECXTS^time ECTIME^primary care team 139 ;ECPTTM^primary care provider ECPTPR^pce cpt code & modifers ECXCPT^ 140 ;primary icd-9 code ECDIA^secondary icd-9 #1 ECXICD91^secondary icd-9 141 ;#2 ECXICD92^secondary icd-9 #3 ECXICD93^secondary icd-9 #4 ECXICD94^ 142 ;agent orange ECXAST^radiation exposure ECRST^environmental 143 ;contaminants ECEST^service connected ECSC^sent to pce^^dss identifier 144 ;ECDSS^placeholder 145 ;node1 146 ;mpi ECXNPI^dss dept ECXDSSD^provider npi ECUN1NPI^^^pc prov person 147 ;class ECPTNPI^assoc pc provider ECASPR^assoc pc prov person class 148 ;ECCLAS2^assoc pc provider npi ECASNPI^divison ECXDIV^dom ECXDOM^ 149 ;enrollment category ECXCAT^enrollment status ECXSTAT^enrollment prior 150 ;ECXPRIOR^period of service ECXPOS^purple heart ECXPHI^observ pat ind 151 ;ECXOBS^encounter num ECXENC^ao loc ECXAOL^ord div ECXODIV^contr st dt 152 ;ECXCSDT^contr end dt ECXCEDT^contr typ ECXCTYP^CNH stat ECXCNH^ 153 ;production division ECXPDIV^eligibility ECXELIG^ethnicity ECXETH^ 154 ;race1 ECXRC1^enrollment location ECXENRL^^enrollment priority 155 ;ECXPRIOR_enrollment subgroup ECXSBGRP^user enrollee ECXUESTA^patient 156 ;type ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^ 157 ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI^ 158 ;emergency response indicator(FEMA) ECXERI^agent orange indicator 159 ;ECXAO^environ contam ECXECE^head/neck ECXHNC^military sexual trauma 160 ;ECXMIL^radiation encoun ECXIR^nutrition dx 161 N DA,DIK 162 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 163 S ECODE=EC7_U_EC23_U 164 S ECODE=ECODE_ECL_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U_ECDAY_U_ECDU_U_U 165 S ECODE=ECODE_ECP_U_ECV_U_ECCS_U_ECO_U_ECM_U_ECXPRV1_U_ECXPPC1_U 166 S ECODE=ECODE_ECXPRV2_U_ECXPPC2_U_ECXPRV3_U_ECXPPC3_U_U 167 S ECODE=ECODE_ECXMN_U_ECXTS_U_ECTIME_U_ECPTTM_U 168 S ECODE=ECODE_ECPTPR_U_ECXCPT_U_ECDIA_U_ECXICD91_U_ECXICD92_U 169 S ECODE=ECODE_ECXICD93_U_ECXICD94_U_ECXAST_U_ECXRST_U_ECXEST_U 170 S ECODE=ECODE_ECSC_U_"N"_U_U_ECDSS_U_U 171 S ECODE1=ECXMPI_U_ECXDSSD_U_ECUN1NPI_U_U_U_ECCLAS_U_ECPTNPI_U_ECASPR_U 172 S ECODE1=ECODE1_ECCLAS2_U_ECASNPI_U_ECXDIV_U_ECXMST_U_ECXDOM_U 173 S ECODE1=ECODE1_ECXDOB_U_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U_ECXPHI_U 174 S ECODE1=ECODE1_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXODIV_U_ECXCSDT_U_ECXCEDT_U 175 S ECODE1=ECODE1_ECXCTYP_U_ECXCNH_U_ECXPDIV_U_ECXELIG_U_ECXHNCI_U_ECXETH_U 176 S ECODE1=ECODE1_ECXRC1 177 I ECXLOGIC>2003 S ECODE1=ECODE1_U_ECXENRL 178 I ECXLOGIC>2004 S ECODE1=ECODE1_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U 179 I ECXLOGIC>2004 S ECODE2=ECXCVEDT_U_ECXCVENC_U_ECXNPRFI 180 I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U 181 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1 182 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 183 I $D(ZTQUEUED),$$S^%ZTLOAD 184 Q 185 SETUP ;Set required input for ECXTRAC 186 S ECHEAD="ECQ" 187 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 188 Q 189 QUE ;Entry point for the background requeuing handled by ECXTAUTO. 190 D SETUP,QUE^ECXTAUTO,^ECXKILL Q
Note:
See TracChangeset
for help on using the changeset viewer.
