ECXQSR ;ALB/JAP,BIR/PTD-DSS QUASAR Extract ;12/14/18 15:57
;;3.0;DSS EXTRACTS;**11,8,13,26,24,34,33,35,39,43,46,49,64,71,84,92,106,105,120,124,127,132,136,144,154,161,166,170,173**;Dec 22, 1997;Build 3
BEG ;entry point from option
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
I '$D(^ACK(509850.8,1,"DSS")) W !,"Linkage has not been established between QUASAR and the DSS UNIT file (#724).",!! Q
I '$O(^ACK(509850.6,0)) W !,"There is no data in the A&SP CLINIC VISIT file (#509850.6).",!! Q
D SETUP I ECFILE="" Q
D ^ECXTRAC,^ECXKILL
Q
START ;entry point from tasked job
N ERR,ECXQDT,ECXNPRFI
S QFLG=0,ECED=ECED+.9,ECD=ECSD1,ECXQV=""
D QINST I $D(ERR) Q
S ECL=+^ACK(509850.8,1,0),ECLINK=^ACK(509850.8,1,"DSS")
F S ECD=$O(^ACK(509850.6,"B",ECD)),ECDA=0 Q:(ECD>ECED)!('ECD)!(QFLG) D
.I +ECXQV=3,ECD<ECXQDT S ECXQV=2.0
.F S ECDA=$O(^ACK(509850.6,"B",ECD,ECDA)) Q:'ECDA D UPDATE Q:QFLG
Q
QINST ;Get installed information for QUASAR
N ARR,IENS,QVIEN,INTIEN
S ECXQDT=""
D FILE^DID(509850.6,,"VERSION","ARR","ERR")
S ECXQV=$G(ARR("VERSION")) I +ECXQV=0 S ERR=1 Q
S QVIEN=$$FIND1^DIC(9.4,"","X","QUASAR") I +QVIEN<1 S ERR=1 Q
S IENS=","_QVIEN_","
S INTIEN=$$FIND1^DIC(9.49,IENS,"X",ECXQV) I +INTIEN<1 S ERR=1 Q
S IENS=INTIEN_","_QVIEN,ECXQDT=$$GET1^DIQ(9.49,IENS,2,"I")
Q
UPDATE ;create record for each unique CPT code for clinic visit
N ARY,ECZNODE,CPT,LOC,MOD,STR,VOL,XX,ECTP,ECV,ECUPCE,ECDSSE ;154
N ECXICD10P,ECXICD101,ECXICD102,ECXICD103,ECXICD104,ECXVNS,ECX4CHAR,ECXESC,ECXECL,ECXCLST ;144
N ECXTEMPW,ECXTEMPD,ECXSTANO,ECXASIH ;166,170
Q:'$D(^ACK(509850.6,ECDA,0))
S ECZNODE=^ACK(509850.6,ECDA,0),EC2NODE=$G(^ACK(509850.6,ECDA,2))
S ECDT=$P(ECZNODE,U),ECDAY=$$ECXDATE^ECXUTL(ECDT,ECXYM)
S ECTIME=$$ECXTIME^ECXUTL(ECDT) S:$P(ECDT,".",2)="" ECTIME="000000"
S ECXDFN=$P(ECZNODE,U,2)
Q:'$$PATDEM^ECXUTL2(ECXDFN,ECD,"1;3;5")
S OK=$$PAT^ECXUTL3(ECXDFN,ECDT,"1;5",.ECXPAT)
S ECXCLST="" ;144
I 'OK S ECXERR=1 K ECXPAT Q
;OEF/OIF data
S ECXOEF=ECXPAT("ECXOEF")
S ECXOEFDT=ECXPAT("ECXOEFDT")
S ECXVNS=ECXPAT("VIETNAM") ;144 VIETNAM STATUS CVW
S ECXCLST=ECXPAT("CL STAT") ;144 Camp Lejeune Status
;
S ECHL="",ECXDIV=$P($G(^ACK(509850.6,ECDA,5)),U),ECSTOP=$P(EC2NODE,U)
S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV) ; Get Production Division
Q:ECSTOP=""
S ECXSTANO=ECXPDIV ;166 tjl - Set default Patient Division
I ECXA="I",$D(^DGPM(ECXMN,0)) D ;166 tjl - Set Patient Division for inpatients based on Patient Movement record
. S ECXTEMPW=$P($G(^DGPM(ECXMN,0)),U,6)
. S ECXTEMPD=$P($G(^DIC(42,+ECXTEMPW,0)),U,11)
. S ECXSTANO=$$GETDIV^ECXDEPT(ECXTEMPD)
;154 Following 3 lines of code moved here to set variables earlier
S ECDU=$S(ECSTOP["A":$P(ECLINK,U),ECSTOP["S":$P(ECLINK,U,2),1:"")
Q:'ECDU
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),ECUPCE=$P(ECDSSU,U,14)
S (ECHLS,ECHL2S)="000",ECAC=$P($G(ECZNODE),U,6)
I ECUPCE="A"!(ECUPCE="O"&(ECXA="O"))!(ECUPCE="OOS") D ;154,173 add "OOS" units
.I ECAC D ;154
..S ECHL=+$P($G(^SC(ECAC,0)),U,7),ECHL2=+$P($G(^(0)),U,18) I ECHL D ;154
...S ECHLS=$P($G(^DIC(40.7,+ECHL,0)),U,2),ECHL2S=$P($G(^DIC(40.7,+ECHL2,0)),U,2) ;154
...S ECHLS=$$RJ^XLFSTR(ECHLS,3,0),ECHL2S=$$RJ^XLFSTR(ECHL2S,3,0) ;154
...S ECX4CHAR=$$RJ^XLFSTR($$GET1^DIQ(728.44,+ECAC,7,"E"),4,0) ;154 Get 4char code
I ECUPCE=""!(ECUPCE="N")!(ECUPCE="O"&(ECXA="I")) D ;154
.S ECHLS=$$RJ^XLFSTR($P($G(^DIC(40.7,+$P(ECDSSU,U,10),0)),U,2),3,0) ;154
.S ECHL2S=$$RJ^XLFSTR($P($G(^DIC(40.7,+$P(ECDSSU,U,13),0)),U,2),3,0) ;154
.S ECX4CHAR=$$RJ^XLFSTR($$GET1^DIQ(728.441,+$P(ECDSSU,U,15),.01,"E"),4,0) ;154
S ECDSS=ECHLS_ECHL2S
I ECXLOGIC>2003 D
.I "^18^23^24^41^65^94^108^"[("^"_ECXTS_"^") S ECDSS=$$TSMAP^ECXUTL4(ECXTS)
Q:'$O(^ACK(509850.6,ECDA,3,0))
;Create local array of procedure codes and # of times each procedure
; was performed.
F I=1:1:4 S @("ECXICD9"_I)=""
F I=1:1:4 S @("ECXICD10"_I)=""
S (ECDIA,ECXPPC,ECXPRV1,ECXPRV2,ECXPRV3,ECXPRV4,ECXPRV5,ECXPRV6,ECXPRV7,ECXICD10P)="" ;144 MORE PROVIDERS
;if QUASAR v2
I +ECXQV=2 D
.S ECXPRV1=$P(EC2NODE,U,7),ECXPRV2=$P(EC2NODE,U,3),ECXPRV3=$P(EC2NODE,U,5),ECPN=0
.F S ECPN=$O(^ACK(509850.6,ECDA,3,ECPN)) Q:'ECPN D
..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)
..I ECXCPT]"" D
...I '$D(LOC(ECXCPT)) S LOC(ECXCPT)=0_U_ECXPRV1
...S $P(LOC(ECXCPT),U)=$P(LOC(ECXCPT),U)+1
.S ECIEN=$O(^ACK(509850.6,ECDA,1,0)),ECDIA=$P($G(^ICD9(+$G(^ACK(509850.6,ECDA,1,ECIEN,0)),0)),U)
.F I=1:1:4 S ECIEN=$O(^ACK(509850.6,ECDA,1,ECIEN)) Q:'+ECIEN D
..S @("ECXICD9"_I)=$P($G(^ICD9(+$P(^ACK(509850.6,ECDA,1,ECIEN,0),U),0)),U)
;if QUASAR v3
I +ECXQV=3 D
.N CPT,DIA,I,J,MOD,MOD1,P,STR,VOL,ECTP,ARY,ECP,ECPN
.S ECXPRV2=$G(^ACK(509850.6,ECDA,2.7,1,0)),ECXPRV3=$G(^ACK(509850.6,ECDA,2.7,2,0)),ECXPRV4=$G(^ACK(509850.6,ECDA,2.7,3,0)),ECXPRV5=$G(^ACK(509850.6,ECDA,2.7,4,0))
.S ECXPRV6=$G(^ACK(509850.6,ECDA,2.7,5,0)),ECXPRV7=$G(^ACK(509850.6,ECDA,2.7,6,0)) ;144 more prov
.I $G(ECXPRV2) S ECXPRV2=$$CONVERT1^ACKQUTL4(ECXPRV2)
.I $G(ECXPRV3) S ECXPRV3=$$CONVERT1^ACKQUTL4(ECXPRV3)
.I $G(ECXPRV4) S ECXPRV4=$$CONVERT1^ACKQUTL4(ECXPRV4)
.I $G(ECXPRV5) S ECXPRV5=$$CONVERT1^ACKQUTL4(ECXPRV5)
.I $G(ECXPRV6) S ECXPRV6=$$CONVERT1^ACKQUTL4(ECXPRV6) ;144
.I $G(ECXPRV7) S ECXPRV7=$$CONVERT1^ACKQUTL4(ECXPRV7) ;144
.S ECPN=0 F S ECPN=$O(^ACK(509850.6,ECDA,3,ECPN)) Q:'ECPN D
..S CPT=^ACK(509850.6,ECDA,3,ECPN,0),ECXCPT=$P(CPT,U),ECTP=+$P(CPT,U,5),ECV=1,ECP=""
..Q:ECXCPT=""
..I ECTP D
...S CPT=$G(^ACK(509850.6,ECDA,7,ECTP,0)),ECP=$P(CPT,U)
...S ECP=$S(ECP<90000:$P($G(^EC(725,+ECP,0)),U,2)_"N",1:$P($G(^EC(725,+ECP,0)),U,2)_"L")
...S VOL=+$P(CPT,U,2),ECXPRV1=$P(CPT,U,3)
..I 'ECTP S VOL=+$P(CPT,U,3),ECXPRV1=$P(CPT,U,4)
..I $G(ECXPRV1) S ECXPRV1=$$CONVERT1^ACKQUTL4(ECXPRV1)
..S ECXCPT=$E($$CPT^ECXUTL3(ECXCPT),1,5),ECXMOD="",MOD=0
..F S MOD=$O(^ACK(509850.6,ECDA,3,ECPN,1,MOD)) Q:'MOD D
...S MOD1=+^ACK(509850.6,ECDA,3,ECPN,1,MOD,0) D:MOD1
....S ECXMOD=ECXMOD_MOD1_";"
..F I=1:1:$L(ECXMOD,";") I $G(ARY(ECXCPT))'[$P(ECXMOD,";",I) D
...S ARY(ECXCPT)=$G(ARY(ECXCPT))_$P(ECXMOD,";",I)_";"
..S:VOL ECV=VOL
..S ECV=ECV+$G(LOC(ECXCPT)),LOC(ECXCPT)=ECV_U_ECXPRV1_U_ECP
.S ECIEN=0 F S ECIEN=$O(^ACK(509850.6,ECDA,1,ECIEN)) Q:'ECIEN D
..S DIA=^ACK(509850.6,ECDA,1,ECIEN,0),P=$P(DIA,U,2),P=$S(P=1:"P",1:"S")
..I +DIA S CNT=$G(STR(P))+1,STR(P,CNT)=$$CODEC^ICDEX(80,+DIA),STR(P)=CNT ;154
.S ECXICD10P=$G(STR("P",1)) ;161
.F I=1:1:4 Q:'$D(STR("P",I+1)) S @("ECXICD10"_I)=STR("P",I) ;161
.S:ECXICD10P="" ECXICD10P=$G(STR("S",1)),I=2 ;161
.F J=I:1:4 Q:'$D(STR("S",J)) S @("ECXICD10"_J)=STR("S",J) ;161
Q:('$D(LOC))!('$O(^ACK(509850.6,ECDA,1,0)))
;- Ord Div, Contract St/End Dates, Contract Type placeholders for FY2002
S (ECXODIV,ECXCSDT,ECXCEDT,ECXCTYP)=""
;set up Provider Person class
S (ECXCPT,ECXPPC1,ECXPPC2,ECXPPC3,ECXPPC4,ECXPPC5,ECXPPC6,ECXPPC7)="" ;144 new ppc
S:ECXPRV2'="" ECXPPC2=$$PRVCLASS^ECXUTL(ECXPRV2,ECD)
S:ECXPRV3'="" ECXPPC3=$$PRVCLASS^ECXUTL(ECXPRV3,ECD)
S:ECXPRV4'="" ECXPPC4=$$PRVCLASS^ECXUTL(ECXPRV4,ECD)
S:ECXPRV5'="" ECXPPC5=$$PRVCLASS^ECXUTL(ECXPRV5,ECD)
S:ECXPRV6'="" ECXPPC6=$$PRVCLASS^ECXUTL(ECXPRV6,ECD) ;144
S:ECXPRV7'="" ECXPPC7=$$PRVCLASS^ECXUTL(ECXPRV7,ECD) ;144
;set up Provider NPI
S (ECPR1NPI,ECPR2NPI,ECPR3NPI,ECPR4NPI,ECPR5NPI,ECPR6NPI,ECPR7NPI)="" ;144 new npi
S ECPR2NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV2,ECD)
S:+ECPR2NPI'>0 ECPR2NPI="" S ECPR2NPI=$P(ECPR2NPI,U)
S ECPR3NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV3,ECD)
S:+ECPR3NPI'>0 ECPR3NPI="" S ECPR3NPI=$P(ECPR3NPI,U)
S ECPR4NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV4,ECD)
S:+ECPR4NPI'>0 ECPR4NPI="" S ECPR4NPI=$P(ECPR4NPI,U)
S ECPR5NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV5,ECD)
S:+ECPR5NPI'>0 ECPR5NPI="" S ECPR5NPI=$P(ECPR5NPI,U)
S ECPR6NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV6,ECD) ;144
S:+ECPR6NPI'>0 ECPR6NPI="" S ECPR6NPI=$P(ECPR6NPI,U) ;144
S ECPR7NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV7,ECD) ;144
S:+ECPR7NPI'>0 ECPR7NPI="" S ECPR7NPI=$P(ECPR7NPI,U) ;144
N DA,DIC,DIK,DR,FILEN,DIQ,XVAR,II,DI
F II=2,3,4,5,6,7 S XVAR="ECXPRV"_II I @XVAR'="" D
.S @XVAR=2_@XVAR
; -Observation Patient Indicator (yes/no)
S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECDSS)
; -CNH status (YES/NO)
S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN)
;get encounter classification
S (ECXAO,ECXECE,ECXIR,ECXMIL,ECXHNC,ECXSHAD,ECXESC,ECXECL)="",ECXVISIT=$P($G(^ACK(509850.6,ECDA,6)),U,3) ;144
I ECXVISIT'="" D
.D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q
.S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE")),ECXSHAD=$G(ECXVIST("SHAD"))
.S ECXIR=$G(ECXVIST("IR")),ECXMIL=$G(ECXVIST("MST")),ECXHNC=$G(ECXVIST("HNC"))
.S ECXESC=$G(ECXVIST("ENCSC")),ECXECL=$G(ECXVIST("ENCCL")) ;144
; -Head and Neck Cancer Indicator
S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
; -PROJ 112/SHAD Indicator
S ECXSHADI=$$SHAD^ECXUTL4(ECXDFN)
; ******* - PATCH 127, ADD PATCAT CODE - ********
S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
;get enrollment data (category, status and priority)
I $$ENROLLM^ECXUTL2(ECXDFN)
; -Get national patient record flag Indicator if exist
D NPRF^ECXUTL5
; -If no encounter number don't file record
S ECDSSE=$S(ECHLS<101!(ECHLS>999):"ECQ",1:ECHLS)_ECHL2S ;154 If stop code is invalid set it to ECQ for encounter number creation
S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECDT,ECXTS,ECXOBS,ECHEAD,ECDSSE,) ;154 Send ECDSSE for encounter # creation
Q:ECXENC=""
I $G(ECXASIH) S ECXA="A" ;170
;Loop through array of unique procedures. Create record in ECODE.
S CPT="" F S CPT=$O(LOC(CPT)) Q:CPT="" D
.S ECV=+$P(LOC(CPT),U),ECXCPT=$$CPT^ECXUTL3(CPT,$G(ARY(CPT)),ECV)
.S ECXPRV1=$P(LOC(CPT),U,2)
.S:ECXPRV1'="" ECXPPC1=$$PRVCLASS^ECXUTL(ECXPRV1,ECD)
.S ECPR1NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV1,ECD)
.S:+ECPR1NPI'>0 ECPR1NPI="" S ECPR1NPI=$P(ECPR1NPI,U)
.S:ECXPRV1'="" ECXPRV1=2_ECXPRV1
.S ECP=$P(LOC(CPT),U,3) I ECP="" S ECP=$$CPT^ECXUTL3(CPT,"",ECV)
.D FILE^ECXQSR1
K CPT,LOC
Q
SETUP ;Set required input for ECXTRAC
S ECHEAD="ECQ"
D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
Q
QUE ;Entry point for the background requeuing handled by ECXTAUTO.
D SETUP,QUE^ECXTAUTO,^ECXKILL Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXQSR 10500 printed Sep 23, 2025@19:29:45 Page 2
ECXQSR ;ALB/JAP,BIR/PTD-DSS QUASAR Extract ;12/14/18 15:57
+1 ;;3.0;DSS EXTRACTS;**11,8,13,26,24,34,33,35,39,43,46,49,64,71,84,92,106,105,120,124,127,132,136,144,154,161,166,170,173**;Dec 22, 1997;Build 3
BEG ;entry point from option
+1 IF '$ORDER(^ACK(509850.8,0))
WRITE !,"You must be using the Quality Audiology & Speech Pathology",!,"Audit & Review (QUASAR) software to run this extract.",!!
QUIT
+2 IF '$DATA(^ACK(509850.8,1,"DSS"))
WRITE !,"Linkage has not been established between QUASAR and the DSS UNIT file (#724).",!!
QUIT
+3 IF '$ORDER(^ACK(509850.6,0))
WRITE !,"There is no data in the A&SP CLINIC VISIT file (#509850.6).",!!
QUIT
+4 DO SETUP
IF ECFILE=""
QUIT
+5 DO ^ECXTRAC
DO ^ECXKILL
+6 QUIT
START ;entry point from tasked job
+1 NEW ERR,ECXQDT,ECXNPRFI
+2 SET QFLG=0
SET ECED=ECED+.9
SET ECD=ECSD1
SET ECXQV=""
+3 DO QINST
IF $DATA(ERR)
QUIT
+4 SET ECL=+^ACK(509850.8,1,0)
SET ECLINK=^ACK(509850.8,1,"DSS")
+5 FOR
SET ECD=$ORDER(^ACK(509850.6,"B",ECD))
SET ECDA=0
if (ECD>ECED)!('ECD)!(QFLG)
QUIT
Begin DoDot:1
+6 IF +ECXQV=3
IF ECD<ECXQDT
SET ECXQV=2.0
+7 FOR
SET ECDA=$ORDER(^ACK(509850.6,"B",ECD,ECDA))
if 'ECDA
QUIT
DO UPDATE
if QFLG
QUIT
End DoDot:1
+8 QUIT
QINST ;Get installed information for QUASAR
+1 NEW ARR,IENS,QVIEN,INTIEN
+2 SET ECXQDT=""
+3 DO FILE^DID(509850.6,,"VERSION","ARR","ERR")
+4 SET ECXQV=$GET(ARR("VERSION"))
IF +ECXQV=0
SET ERR=1
QUIT
+5 SET QVIEN=$$FIND1^DIC(9.4,"","X","QUASAR")
IF +QVIEN<1
SET ERR=1
QUIT
+6 SET IENS=","_QVIEN_","
+7 SET INTIEN=$$FIND1^DIC(9.49,IENS,"X",ECXQV)
IF +INTIEN<1
SET ERR=1
QUIT
+8 SET IENS=INTIEN_","_QVIEN
SET ECXQDT=$$GET1^DIQ(9.49,IENS,2,"I")
+9 QUIT
UPDATE ;create record for each unique CPT code for clinic visit
+1 ;154
NEW ARY,ECZNODE,CPT,LOC,MOD,STR,VOL,XX,ECTP,ECV,ECUPCE,ECDSSE
+2 ;144
NEW ECXICD10P,ECXICD101,ECXICD102,ECXICD103,ECXICD104,ECXVNS,ECX4CHAR,ECXESC,ECXECL,ECXCLST
+3 ;166,170
NEW ECXTEMPW,ECXTEMPD,ECXSTANO,ECXASIH
+4 if '$DATA(^ACK(509850.6,ECDA,0))
QUIT
+5 SET ECZNODE=^ACK(509850.6,ECDA,0)
SET EC2NODE=$GET(^ACK(509850.6,ECDA,2))
+6 SET ECDT=$PIECE(ECZNODE,U)
SET ECDAY=$$ECXDATE^ECXUTL(ECDT,ECXYM)
+7 SET ECTIME=$$ECXTIME^ECXUTL(ECDT)
if $PIECE(ECDT,".",2)=""
SET ECTIME="000000"
+8 SET ECXDFN=$PIECE(ECZNODE,U,2)
+9 if '$$PATDEM^ECXUTL2(ECXDFN,ECD,"1;3;5")
QUIT
+10 SET OK=$$PAT^ECXUTL3(ECXDFN,ECDT,"1;5",.ECXPAT)
+11 ;144
SET ECXCLST=""
+12 IF 'OK
SET ECXERR=1
KILL ECXPAT
QUIT
+13 ;OEF/OIF data
+14 SET ECXOEF=ECXPAT("ECXOEF")
+15 SET ECXOEFDT=ECXPAT("ECXOEFDT")
+16 ;144 VIETNAM STATUS CVW
SET ECXVNS=ECXPAT("VIETNAM")
+17 ;144 Camp Lejeune Status
SET ECXCLST=ECXPAT("CL STAT")
+18 ;
+19 SET ECHL=""
SET ECXDIV=$PIECE($GET(^ACK(509850.6,ECDA,5)),U)
SET ECSTOP=$PIECE(EC2NODE,U)
+20 ; Get Production Division
SET ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV)
+21 if ECSTOP=""
QUIT
+22 ;166 tjl - Set default Patient Division
SET ECXSTANO=ECXPDIV
+23 ;166 tjl - Set Patient Division for inpatients based on Patient Movement record
IF ECXA="I"
IF $DATA(^DGPM(ECXMN,0))
Begin DoDot:1
+24 SET ECXTEMPW=$PIECE($GET(^DGPM(ECXMN,0)),U,6)
+25 SET ECXTEMPD=$PIECE($GET(^DIC(42,+ECXTEMPW,0)),U,11)
+26 SET ECXSTANO=$$GETDIV^ECXDEPT(ECXTEMPD)
End DoDot:1
+27 ;154 Following 3 lines of code moved here to set variables earlier
+28 SET ECDU=$SELECT(ECSTOP["A":$PIECE(ECLINK,U),ECSTOP["S":$PIECE(ECLINK,U,2),1:"")
+29 if 'ECDU
QUIT
+30 SET ECDSSU=$GET(^ECD(ECDU,0))
SET ECCS=+$PIECE(ECDSSU,U,4)
SET (ECO,ECM)=+$PIECE(ECDSSU,U,3)
SET ECXDSSD=$EXTRACT($PIECE(ECDSSU,U,5),1,10)
SET ECUPCE=$PIECE(ECDSSU,U,14)
+31 SET (ECHLS,ECHL2S)="000"
SET ECAC=$PIECE($GET(ECZNODE),U,6)
+32 ;154,173 add "OOS" units
IF ECUPCE="A"!(ECUPCE="O"&(ECXA="O"))!(ECUPCE="OOS")
Begin DoDot:1
+33 ;154
IF ECAC
Begin DoDot:2
+34 ;154
SET ECHL=+$PIECE($GET(^SC(ECAC,0)),U,7)
SET ECHL2=+$PIECE($GET(^(0)),U,18)
IF ECHL
Begin DoDot:3
+35 ;154
SET ECHLS=$PIECE($GET(^DIC(40.7,+ECHL,0)),U,2)
SET ECHL2S=$PIECE($GET(^DIC(40.7,+ECHL2,0)),U,2)
+36 ;154
SET ECHLS=$$RJ^XLFSTR(ECHLS,3,0)
SET ECHL2S=$$RJ^XLFSTR(ECHL2S,3,0)
+37 ;154 Get 4char code
SET ECX4CHAR=$$RJ^XLFSTR($$GET1^DIQ(728.44,+ECAC,7,"E"),4,0)
End DoDot:3
End DoDot:2
End DoDot:1
+38 ;154
IF ECUPCE=""!(ECUPCE="N")!(ECUPCE="O"&(ECXA="I"))
Begin DoDot:1
+39 ;154
SET ECHLS=$$RJ^XLFSTR($PIECE($GET(^DIC(40.7,+$PIECE(ECDSSU,U,10),0)),U,2),3,0)
+40 ;154
SET ECHL2S=$$RJ^XLFSTR($PIECE($GET(^DIC(40.7,+$PIECE(ECDSSU,U,13),0)),U,2),3,0)
+41 ;154
SET ECX4CHAR=$$RJ^XLFSTR($$GET1^DIQ(728.441,+$PIECE(ECDSSU,U,15),.01,"E"),4,0)
End DoDot:1
+42 SET ECDSS=ECHLS_ECHL2S
+43 IF ECXLOGIC>2003
Begin DoDot:1
+44 IF "^18^23^24^41^65^94^108^"[("^"_ECXTS_"^")
SET ECDSS=$$TSMAP^ECXUTL4(ECXTS)
End DoDot:1
+45 if '$ORDER(^ACK(509850.6,ECDA,3,0))
QUIT
+46 ;Create local array of procedure codes and # of times each procedure
+47 ; was performed.
+48 FOR I=1:1:4
SET @("ECXICD9"_I)=""
+49 FOR I=1:1:4
SET @("ECXICD10"_I)=""
+50 ;144 MORE PROVIDERS
SET (ECDIA,ECXPPC,ECXPRV1,ECXPRV2,ECXPRV3,ECXPRV4,ECXPRV5,ECXPRV6,ECXPRV7,ECXICD10P)=""
+51 ;if QUASAR v2
+52 IF +ECXQV=2
Begin DoDot:1
+53 SET ECXPRV1=$PIECE(EC2NODE,U,7)
SET ECXPRV2=$PIECE(EC2NODE,U,3)
SET ECXPRV3=$PIECE(EC2NODE,U,5)
SET ECPN=0
+54 FOR
SET ECPN=$ORDER(^ACK(509850.6,ECDA,3,ECPN))
if 'ECPN
QUIT
Begin DoDot:2
+55 SET XX=^ACK(509850.6,ECDA,3,ECPN,0)
SET XX=$PIECE(XX,U)
SET XX=$PIECE($GET(^ACK(509850.4,XX,0)),U)
SET ECXCPT=$EXTRACT($$CPT^ECXUTL3(XX),1,5)
+56 IF ECXCPT]""
Begin DoDot:3
+57 IF '$DATA(LOC(ECXCPT))
SET LOC(ECXCPT)=0_U_ECXPRV1
+58 SET $PIECE(LOC(ECXCPT),U)=$PIECE(LOC(ECXCPT),U)+1
End DoDot:3
End DoDot:2
+59 SET ECIEN=$ORDER(^ACK(509850.6,ECDA,1,0))
SET ECDIA=$PIECE($GET(^ICD9(+$GET(^ACK(509850.6,ECDA,1,ECIEN,0)),0)),U)
+60 FOR I=1:1:4
SET ECIEN=$ORDER(^ACK(509850.6,ECDA,1,ECIEN))
if '+ECIEN
QUIT
Begin DoDot:2
+61 SET @("ECXICD9"_I)=$PIECE($GET(^ICD9(+$PIECE(^ACK(509850.6,ECDA,1,ECIEN,0),U),0)),U)
End DoDot:2
End DoDot:1
+62 ;if QUASAR v3
+63 IF +ECXQV=3
Begin DoDot:1
+64 NEW CPT,DIA,I,J,MOD,MOD1,P,STR,VOL,ECTP,ARY,ECP,ECPN
+65 SET ECXPRV2=$GET(^ACK(509850.6,ECDA,2.7,1,0))
SET ECXPRV3=$GET(^ACK(509850.6,ECDA,2.7,2,0))
SET ECXPRV4=$GET(^ACK(509850.6,ECDA,2.7,3,0))
SET ECXPRV5=$GET(^ACK(509850.6,ECDA,2.7,4,0))
+66 ;144 more prov
SET ECXPRV6=$GET(^ACK(509850.6,ECDA,2.7,5,0))
SET ECXPRV7=$GET(^ACK(509850.6,ECDA,2.7,6,0))
+67 IF $GET(ECXPRV2)
SET ECXPRV2=$$CONVERT1^ACKQUTL4(ECXPRV2)
+68 IF $GET(ECXPRV3)
SET ECXPRV3=$$CONVERT1^ACKQUTL4(ECXPRV3)
+69 IF $GET(ECXPRV4)
SET ECXPRV4=$$CONVERT1^ACKQUTL4(ECXPRV4)
+70 IF $GET(ECXPRV5)
SET ECXPRV5=$$CONVERT1^ACKQUTL4(ECXPRV5)
+71 ;144
IF $GET(ECXPRV6)
SET ECXPRV6=$$CONVERT1^ACKQUTL4(ECXPRV6)
+72 ;144
IF $GET(ECXPRV7)
SET ECXPRV7=$$CONVERT1^ACKQUTL4(ECXPRV7)
+73 SET ECPN=0
FOR
SET ECPN=$ORDER(^ACK(509850.6,ECDA,3,ECPN))
if 'ECPN
QUIT
Begin DoDot:2
+74 SET CPT=^ACK(509850.6,ECDA,3,ECPN,0)
SET ECXCPT=$PIECE(CPT,U)
SET ECTP=+$PIECE(CPT,U,5)
SET ECV=1
SET ECP=""
+75 if ECXCPT=""
QUIT
+76 IF ECTP
Begin DoDot:3
+77 SET CPT=$GET(^ACK(509850.6,ECDA,7,ECTP,0))
SET ECP=$PIECE(CPT,U)
+78 SET ECP=$SELECT(ECP<90000:$PIECE($GET(^EC(725,+ECP,0)),U,2)_"N",1:$PIECE($GET(^EC(725,+ECP,0)),U,2)_"L")
+79 SET VOL=+$PIECE(CPT,U,2)
SET ECXPRV1=$PIECE(CPT,U,3)
End DoDot:3
+80 IF 'ECTP
SET VOL=+$PIECE(CPT,U,3)
SET ECXPRV1=$PIECE(CPT,U,4)
+81 IF $GET(ECXPRV1)
SET ECXPRV1=$$CONVERT1^ACKQUTL4(ECXPRV1)
+82 SET ECXCPT=$EXTRACT($$CPT^ECXUTL3(ECXCPT),1,5)
SET ECXMOD=""
SET MOD=0
+83 FOR
SET MOD=$ORDER(^ACK(509850.6,ECDA,3,ECPN,1,MOD))
if 'MOD
QUIT
Begin DoDot:3
+84 SET MOD1=+^ACK(509850.6,ECDA,3,ECPN,1,MOD,0)
if MOD1
Begin DoDot:4
+85 SET ECXMOD=ECXMOD_MOD1_";"
End DoDot:4
End DoDot:3
+86 FOR I=1:1:$LENGTH(ECXMOD,";")
IF $GET(ARY(ECXCPT))'[$PIECE(ECXMOD,";",I)
Begin DoDot:3
+87 SET ARY(ECXCPT)=$GET(ARY(ECXCPT))_$PIECE(ECXMOD,";",I)_";"
End DoDot:3
+88 if VOL
SET ECV=VOL
+89 SET ECV=ECV+$GET(LOC(ECXCPT))
SET LOC(ECXCPT)=ECV_U_ECXPRV1_U_ECP
End DoDot:2
+90 SET ECIEN=0
FOR
SET ECIEN=$ORDER(^ACK(509850.6,ECDA,1,ECIEN))
if 'ECIEN
QUIT
Begin DoDot:2
+91 SET DIA=^ACK(509850.6,ECDA,1,ECIEN,0)
SET P=$PIECE(DIA,U,2)
SET P=$SELECT(P=1:"P",1:"S")
+92 ;154
IF +DIA
SET CNT=$GET(STR(P))+1
SET STR(P,CNT)=$$CODEC^ICDEX(80,+DIA)
SET STR(P)=CNT
End DoDot:2
+93 ;161
SET ECXICD10P=$GET(STR("P",1))
+94 ;161
FOR I=1:1:4
if '$DATA(STR("P",I+1))
QUIT
SET @("ECXICD10"_I)=STR("P",I)
+95 ;161
if ECXICD10P=""
SET ECXICD10P=$GET(STR("S",1))
SET I=2
+96 ;161
FOR J=I:1:4
if '$DATA(STR("S",J))
QUIT
SET @("ECXICD10"_J)=STR("S",J)
End DoDot:1
+97 if ('$DATA(LOC))!('$ORDER(^ACK(509850.6,ECDA,1,0)))
QUIT
+98 ;- Ord Div, Contract St/End Dates, Contract Type placeholders for FY2002
+99 SET (ECXODIV,ECXCSDT,ECXCEDT,ECXCTYP)=""
+100 ;set up Provider Person class
+101 ;144 new ppc
SET (ECXCPT,ECXPPC1,ECXPPC2,ECXPPC3,ECXPPC4,ECXPPC5,ECXPPC6,ECXPPC7)=""
+102 if ECXPRV2'=""
SET ECXPPC2=$$PRVCLASS^ECXUTL(ECXPRV2,ECD)
+103 if ECXPRV3'=""
SET ECXPPC3=$$PRVCLASS^ECXUTL(ECXPRV3,ECD)
+104 if ECXPRV4'=""
SET ECXPPC4=$$PRVCLASS^ECXUTL(ECXPRV4,ECD)
+105 if ECXPRV5'=""
SET ECXPPC5=$$PRVCLASS^ECXUTL(ECXPRV5,ECD)
+106 ;144
if ECXPRV6'=""
SET ECXPPC6=$$PRVCLASS^ECXUTL(ECXPRV6,ECD)
+107 ;144
if ECXPRV7'=""
SET ECXPPC7=$$PRVCLASS^ECXUTL(ECXPRV7,ECD)
+108 ;set up Provider NPI
+109 ;144 new npi
SET (ECPR1NPI,ECPR2NPI,ECPR3NPI,ECPR4NPI,ECPR5NPI,ECPR6NPI,ECPR7NPI)=""
+110 SET ECPR2NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV2,ECD)
+111 if +ECPR2NPI'>0
SET ECPR2NPI=""
SET ECPR2NPI=$PIECE(ECPR2NPI,U)
+112 SET ECPR3NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV3,ECD)
+113 if +ECPR3NPI'>0
SET ECPR3NPI=""
SET ECPR3NPI=$PIECE(ECPR3NPI,U)
+114 SET ECPR4NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV4,ECD)
+115 if +ECPR4NPI'>0
SET ECPR4NPI=""
SET ECPR4NPI=$PIECE(ECPR4NPI,U)
+116 SET ECPR5NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV5,ECD)
+117 if +ECPR5NPI'>0
SET ECPR5NPI=""
SET ECPR5NPI=$PIECE(ECPR5NPI,U)
+118 ;144
SET ECPR6NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV6,ECD)
+119 ;144
if +ECPR6NPI'>0
SET ECPR6NPI=""
SET ECPR6NPI=$PIECE(ECPR6NPI,U)
+120 ;144
SET ECPR7NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV7,ECD)
+121 ;144
if +ECPR7NPI'>0
SET ECPR7NPI=""
SET ECPR7NPI=$PIECE(ECPR7NPI,U)
+122 NEW DA,DIC,DIK,DR,FILEN,DIQ,XVAR,II,DI
+123 FOR II=2,3,4,5,6,7
SET XVAR="ECXPRV"_II
IF @XVAR'=""
Begin DoDot:1
+124 SET @XVAR=2_@XVAR
End DoDot:1
+125 ; -Observation Patient Indicator (yes/no)
+126 SET ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECDSS)
+127 ; -CNH status (YES/NO)
+128 SET ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN)
+129 ;get encounter classification
+130 ;144
SET (ECXAO,ECXECE,ECXIR,ECXMIL,ECXHNC,ECXSHAD,ECXESC,ECXECL)=""
SET ECXVISIT=$PIECE($GET(^ACK(509850.6,ECDA,6)),U,3)
+131 IF ECXVISIT'=""
Begin DoDot:1
+132 DO VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR)
IF ECXERR
KILL ECXERR
QUIT
+133 SET ECXAO=$GET(ECXVIST("AO"))
SET ECXECE=$GET(ECXVIST("PGE"))
SET ECXSHAD=$GET(ECXVIST("SHAD"))
+134 SET ECXIR=$GET(ECXVIST("IR"))
SET ECXMIL=$GET(ECXVIST("MST"))
SET ECXHNC=$GET(ECXVIST("HNC"))
+135 ;144
SET ECXESC=$GET(ECXVIST("ENCSC"))
SET ECXECL=$GET(ECXVIST("ENCCL"))
End DoDot:1
+136 ; -Head and Neck Cancer Indicator
+137 SET ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
+138 ; -PROJ 112/SHAD Indicator
+139 SET ECXSHADI=$$SHAD^ECXUTL4(ECXDFN)
+140 ; ******* - PATCH 127, ADD PATCAT CODE - ********
+141 SET ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
+142 ;get enrollment data (category, status and priority)
+143 IF $$ENROLLM^ECXUTL2(ECXDFN)
+144 ; -Get national patient record flag Indicator if exist
+145 DO NPRF^ECXUTL5
+146 ; -If no encounter number don't file record
+147 ;154 If stop code is invalid set it to ECQ for encounter number creation
SET ECDSSE=$SELECT(ECHLS<101!(ECHLS>999):"ECQ",1:ECHLS)_ECHL2S
+148 ;154 Send ECDSSE for encounter # creation
SET ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECDT,ECXTS,ECXOBS,ECHEAD,ECDSSE,)
+149 if ECXENC=""
QUIT
+150 ;170
IF $GET(ECXASIH)
SET ECXA="A"
+151 ;Loop through array of unique procedures. Create record in ECODE.
+152 SET CPT=""
FOR
SET CPT=$ORDER(LOC(CPT))
if CPT=""
QUIT
Begin DoDot:1
+153 SET ECV=+$PIECE(LOC(CPT),U)
SET ECXCPT=$$CPT^ECXUTL3(CPT,$GET(ARY(CPT)),ECV)
+154 SET ECXPRV1=$PIECE(LOC(CPT),U,2)
+155 if ECXPRV1'=""
SET ECXPPC1=$$PRVCLASS^ECXUTL(ECXPRV1,ECD)
+156 SET ECPR1NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV1,ECD)
+157 if +ECPR1NPI'>0
SET ECPR1NPI=""
SET ECPR1NPI=$PIECE(ECPR1NPI,U)
+158 if ECXPRV1'=""
SET ECXPRV1=2_ECXPRV1
+159 SET ECP=$PIECE(LOC(CPT),U,3)
IF ECP=""
SET ECP=$$CPT^ECXUTL3(CPT,"",ECV)
+160 DO FILE^ECXQSR1
End DoDot:1
+161 KILL CPT,LOC
+162 QUIT
SETUP ;Set required input for ECXTRAC
+1 SET ECHEAD="ECQ"
+2 DO ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+3 QUIT
QUE ;Entry point for the background requeuing handled by ECXTAUTO.
+1 DO SETUP
DO QUE^ECXTAUTO
DO ^ECXKILL
QUIT
