ECXSCX ;ALB/JAP,BIR/DMA,CML,PTD-Clinic Extract ; 02/06/97 10:24 [ 03/26/97 2:10 PM ]
;;3.0;DSS EXTRACTS;**1,3,11,8,13,14,28**;Dec 22, 1997
BEG ;entry point from option
D SETUP I ECFILE="" Q
D ^ECXTRAC,^ECXKILL
Q
;
START ;entry point
N QFLG,TIU
;get ien for tiu in file #839.7
S DIC="^PX(839.7,",DIC(0)="X",X="TEXT INTEGRATION UTILITIES" D ^DIC S TIU=0 S:+Y>0 TIU=+Y K DIC,Y
K ^TMP("ECXS",$J) S ECXMISS=10,ECED=ECED+.3 S SC=0,QFLG=0
;scheduled appts. and appended ekgs: loop through the file (#44)
F S SC=$O(^SC(SC)) Q:('SC)!(QFLG) I $D(^(SC,0)) S EC=^(0) I $P(EC,U,3)="C" S ECSU=$P(EC,U,15) S:'ECSU ECSU=1 D FEEDER^ECXSCX1(SC,ECSD1,.P1,.P2,.P3,.ECST) I ECST'=6 S ECD=ECSD1 D Q:QFLG
.F S ECD=$O(^SC(SC,"S",ECD)) Q:'ECD Q:ECD>ECED Q:QFLG S ECDA=0 F S ECDA=$O(^SC(SC,"S",ECD,1,ECDA)) Q:'ECDA I $D(^(ECDA,0)) D Q:QFLG
..;for each patient appointment in the date range (skip cancellations), examine the APPOINTMENT multiple in the PATIENT file (#2)
..I $S('$D(^SC(SC,"S",ECD,1,ECDA,"C")):1,1:$P(^("C"),U,3)]"") S PTADT=^(0),DFN=$P(PTADT,U) I $D(^DPT(+DFN,0)),$P(PTADT,U,9)="",$P($G(^DPT(DFN,"S",ECD,0)),U,2)'["C" D
...D PAT,AOIRPOW^ECXUTL(DFN,.ECXAIP)
...S ECL=$P(PTADT,U,2),ECL=$$RJ^XLFSTR(ECL,3,0),ECOB=$G(^SC(SC,"S",ECD,1,ECDA,"OB"))]""
...;don't continue with record creation if the clinic appointment can't be found in subfile 2.98
...Q:'$D(^DPT(DFN,"S",ECD,0)) Q:$P(^DPT(DFN,"S",ECD,0),U)'=SC
...K EC2 S EC2=^DPT(DFN,"S",ECD,0) S ECN=$S($P(EC2,U,2)="N":"N",$P(EC2,U,2)="NA":"N",$P(EC2,U,2)="NT":"Q",1:"0")
...S ECIEN=$P(EC2,U,20),ECEKG=$P(EC2,U,5)
...I ECST'=3 S ECFD=P1_P2_ECL_P3_ECN,ECO1=ECO1_U_ECFD_U_ECOB_U_SC D API,FILE
...I ECST=3 S ECFD=P1_"000"_ECL_P3_ECN,ECO1=ECO1_U_ECFD_U_ECOB_U_SC D API,FILE
...I ECST=3 S ECFD=P2_"000"_ECL_P3_ECN,ECO1=ECO1_U_ECFD_U_ECOB_U_SC D API,FILE
...;check for appended visits for EKG (107); if regular appt. is a no-show, append is a no-show
...Q:'ECEKG D
....S $P(ECODE,U,10,12)="1070000280000"_ECN_U_U
....S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
....S $P(ECODE,U,1)=EC7
....D FILE2
;Dispositions, stand-alones, and appended lab and x-ray: loop through the file (#409.68) for date range
S ECD=ECSD1
F S ECD=$O(^SCE("B",ECD)) Q:'ECD!(ECD>ECED) S ECIEN=0 D Q:QFLG
.F S ECIEN=$O(^SCE("B",ECD,ECIEN)) Q:'ECIEN D Q:QFLG
..;quit if no outpatient encounter zero node
..Q:'$D(^SCE(ECIEN,0))
..;fd=1>x-ray or lab record, fd=2>disposition, fd=0>stand-alone visit
..S FD=0,NCNTR=^SCE(ECIEN,0),STOP=$P($G(^DIC(40.7,+$P(NCNTR,U,3),0)),U,2)
..S ENELG=$P($G(^DIC(8,+$P(NCNTR,U,13),0)),U,9) I ENELG S ENELG=$C(ENELG+64)
..;quit if no clinic stop code for encounter
..Q:'STOP
..;clinic stop code equals 105 (x-ray) or 108 (lab)
..I (STOP=105)!(STOP=108) S FD=1 D BLD Q
..;quit if encounter not stop code addition or disposition
..I ($P(NCNTR,U,8)'=2),($P(NCNTR,U,8)'=3) Q
..;originating process type equals disposition
..I $P(NCNTR,U,8)=3 S FD=2 D BLD Q
..;else originating process type equals stop code addition (stand-alone)
..;quit if there is a parent encounter pointer.
..Q:$P($G(NCNTR),U,6)
..D BLD
;send missing clinic msg if needed
D:$D(^TMP("ECXS",$J)) EN^ECXSCX1
K EC,EC1,EC2,ECA,ECCPT,ECCSC,ECD,ECDA,ECEKG,ECFD,ECICD,ECIEN,ECL,ECMN,ECN,ECO1,ECO2,ECOB,ECODE,ECPROV,ECPTPR,ECPTTM,ECREC,ECSC,ECST,ECSU,ECTS,ECVAL,ECVIS
K C,CPT,DFN,ELIG,P1,P11,P2,P3,PTADT,SC,VAERR,VAIP,SEX,ADDR,STATE,CNTY,ENELG,PAYOR,SAI,ENR,MST,MSTEI
Q
;
BLD ;build record from outpatient encounter
S DFN=+$P(NCNTR,U,2),LOC=$P(NCNTR,U,4),ECSU=1 S:LOC ECSU=$P(^SC(LOC,0),U,15)
Q:'$D(^DPT(DFN,0))
D PAT,AOIRPOW^ECXUTL(DFN,.ECXAIP)
S P1=$$RJ^XLFSTR(STOP,3,0),P2="000",P3="0000",ECST=1
;for x-ray and lab
I FD=1 S ECO1=ECO1_U_P1_P2_"02800000"_U_U D API,FILE Q
;for dispositions
I FD=2 S ECO1=ECO1_U_P1_"47906000000"_U_U D API,FILE Q
;for stand-alone visits
I FD=0,LOC,$D(^SC(LOC,0)) D
.S SC=LOC,APTLEN=29
.D FEEDER^ECXSCX1(SC,ECD,.P1,.P2,.P3,.ECST)
.I ECST'=6 D
..D API
..I $D(^TMP("PXKENC",$J,ECVIS,"VST",ECVIS,812)) D
...S ECXSRCE=$P(^TMP("PXKENC",$J,ECVIS,"VST",ECVIS,812),U,3)
...I ECXSRCE=TIU S APTLEN=+$P($G(^SC(SC,"SL")),U,1) S:APTLEN=0 APTLEN=29
..S APTLEN=$TR($J(APTLEN,3)," ","0")
..S ECO1=ECO1_U_P1_P2_APTLEN_P3_"0"_U_U_SC
..D FILE
Q
;
FILE ;finish record setup
;node0
;facility^dfn^ssn^name^in/out status^day^feeder key^overbook^sc^mov #^treat spec^time^primary care team^
;primary care provider^provider^CPT code^ICD-9 code^dob^eligibility^vet^race^
;ao status^ao visit^ir status^ir visit^pow status^pow location^provider person class
;node1
;mpi^dss dept^sex^zip+4^pc provider npi^provider npi^encounter elig^mst status^mst indicator
;cpt2^cpt3^cpt4^cpt5^cpt6^cpt7^cpt8^cpt9^cpt10^cpt11^sharing payor^sharing insurance^enr location^state^county^pc prov person class
S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
S ECODE=EC7_U_EC23
S ECODE=ECODE_U_ECO1
S $P(ECODE,U,8)=ECA,ECODE=ECODE_U_ECMN_U_ECTS_U_$$ECXTIME^ECXUTL(ECD)_U_ECPTTM_U_ECPTPR_U_ECPROV_U_ECCPT_U_ECICD
S ECODE=ECODE_U_$$ECXDOB^ECXUTL(DOB)_U_ELIG_U_VET_U_RACE
S ECODE=ECODE_U_ECXAIP("AO")_U_ECVAO_U_ECXAIP("IR")_U_ECVIR_U_ECXAIP("POW")_U_ECXAIP("POWL")_U_ECXPRPC
S CPT="" F C=2:1:11 S CPT=CPT_CPT(C) I C<11 S CPT=CPT_U
S ECODE1=U_U_SEX_U_ZIP_U_U_U_ENELG_U_MST_U_MSTEI_U_CPT_U_PAYOR_U_SAI_U_ENR_U_STATE_U_CNTY_U_ECCLAS
D CUT^ECXSCX1(.ECODE,.ECODE1)
D FILE2
Q
;
FILE2 ;file record
N DA,DIK
S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
S DA=EC7,DIK="^ECX("_ECFILE_"," D IX^DIK K DIK,DA
I $D(ZTQUEUED),ECRN>499,'(ECRN#500),$$S^%ZTLOAD S QFLG=1
Q
;
SETUP ;Set required input for ECXTRAC
S ECHEAD="CLI"
D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
Q
;
PAT ;patient file data
N VAPA
S EC1=^DPT(DFN,0)
S ECO1=ECSU_U_DFN_U_$P(EC1,U,9)_U_$E($P($P(EC1,U),",")_" ",1,4)_U_U_$$ECXDATE^ECXUTL(ECD,ECXYM)
S ELIG=$P($G(^DIC(8,+$G(^DPT(DFN,.36)),0)),U,9) I ELIG S ELIG=$C(ELIG+64)
S SEX=$P(EC1,U,2),DOB=$P(EC1,U,3),VET=$P($G(^DPT(DFN,"VET")),U),RACE=$P($G(^DIC(10,+$P(EC1,U,6),0)),U,2)
D ADD^VADPT
S STATE=VAPA(5),CNTY=VAPA(7),ZIP=$P(VAPA(11),U,2)
S STATE=$P($G(^DIC(5,+STATE,0)),U,3),CNTY=$P($G(^DIC(5,+STATE,1,+CNTY,0)),U,3)
S ENR=$P($G(^DPT(DFN,"ENR")),U,2) I ENR D
.S DIC="^DIC(4,",DA=ENR,DR="99;",DIQ(0)="I",DIQ="ENR"
.D EN^DIQ1 S ENR=ENR(4,ENR,99,"I")
.K DIC,DIQ,DA,DR
S (MST,MSTEI)=""
;get visn 19 sharing agreement data
D VISN19^ECXUTL2(DFN,.PAYOR,.SAI)
Q
API ;call external utilities
;determine in/out status and primary care
N X,PROV
F C=2:1:11 S CPT(C)=""
S X=$$INP^ECXUTL2(DFN,ECD),ECA=$P(X,U,1),ECMN=$P(X,U,2),ECTS=$P(X,U,3)
S X=$$PRIMARY^ECXUTL2(DFN,ECD),ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3)
;call pce api for cpt code, diagnosis/provider designated as primary
S ENELG="",ECPROV="",ECXPRPC="",ECCPT=99199,ECICD=799.9,ECVAO="",ECVIR=""
I 'ECIEN Q
I ECIEN D
.S ECVIS=+$P($G(^SCE(ECIEN,0)),U,5)
.S ENELG=+$P($G(^SCE(ECIEN,0)),U,13),ENELG=$P($G(^DIC(8,ENELG,0)),U,9)
.I ENELG S ENELG=$C(ENELG+64)
I 'ECVIS Q
I ECVIS D ENCEVENT^PXAPI(ECVIS)
I $O(^TMP("PXKENC",$J,ECVIS,""))']"" Q
;get icd9 code; else use 799.9
I $O(^TMP("PXKENC",$J,ECVIS,"POV",0)) D
.S (ECREC,ECVAL)=0
.F S ECREC=$O(^TMP("PXKENC",$J,ECVIS,"POV",ECREC)) Q:'ECREC S:($P(^TMP("PXKENC",$J,ECVIS,"POV",ECREC,0),U,12)="P") ECVAL=+^(0) Q:$P(^TMP("PXKENC",$J,ECVIS,"POV",ECREC,0),U,12)="P"
.I 'ECVAL S ECREC=$O(^TMP("PXKENC",$J,ECVIS,"POV",0)) I ECREC S ECVAL=+^(ECREC,0)
.I ECVAL S ECICD=$P($G(^ICD9(ECVAL,0)),U)
;get first provider designated as primary; if no primary, then get first physician provider; if no physician, then get first provider; if no "prv" array nodes, use null.
I $O(^TMP("PXKENC",$J,ECVIS,"PRV",0)) D
.S (ECREC,ECVAL)=0
.F S ECREC=$O(^TMP("PXKENC",$J,ECVIS,"PRV",ECREC)) Q:'ECREC S:($P(^TMP("PXKENC",$J,ECVIS,"PRV",ECREC,0),U,4)="P") ECVAL=+^(0) Q:$P(^TMP("PXKENC",$J,ECVIS,"PRV",ECREC,0),U,4)="P"
.I ECVAL S ECPROV=ECVAL,ECXPRPC=$$PRVCLASS^ECXUTL(ECPROV,ECD)
.I 'ECVAL S ECREC=0 D
..F S ECREC=$O(^TMP("PXKENC",$J,ECVIS,"PRV",ECREC)) Q:'ECREC D Q:ECVAL
...S ECVAL=+^TMP("PXKENC",$J,ECVIS,"PRV",ECREC,0) Q:'ECVAL
...S ECXPRPC=$$PRVCLASS^ECXUTL(ECVAL,ECD) Q:ECXPRPC=""
...S NUM=$E(ECXPRPC,2,7) S:(NUM<110000)!(NUM>119999) ECVAL=0,ECXPRPC=""
...I ECVAL S ECPROV=ECVAL
.I 'ECVAL D
..S ECREC=$O(^TMP("PXKENC",$J,ECVIS,"PRV",0)) Q:'ECREC S ECVAL=+^(ECREC,0)
..I ECVAL S ECPROV=ECVAL,ECXPRPC=$$PRVCLASS^ECXUTL(ECPROV,ECD)
.S:ECPROV]"" ECPROV="2"_ECPROV
;get cpt code for ien
I $O(^TMP("PXKENC",$J,ECVIS,"CPT",0)) D
.S (ECREC,ECVAL)=0
.;if there's a primary provider, get a cpt associated with that provider
.I ECPROV]"" D
..S PROV=$E(ECPROV,2,99)
..F S ECREC=$O(^TMP("PXKENC",$J,ECVIS,"CPT",ECREC)) Q:'ECREC D Q:ECVAL
...I $D(^TMP("PXKENC",$J,ECVIS,"CPT",ECREC,12)) S:$P(^(12),U,4)=PROV ECVAL=+^TMP("PXKENC",$J,ECVIS,"CPT",ECREC,0)
...I ECVAL D
....S ECCPT=$P($G(^ICPT(ECVAL,0)),U)
...;get rid of the cpt record
...K ^TMP("PXKENC",$J,ECVIS,"CPT",ECREC)
.I ECVAL=0 S ECREC=+$O(^TMP("PXKENC",$J,ECVIS,"CPT",0)) I ECREC S ECVAL=+^(ECREC,0)
.I ECVAL D
..S ECCPT=$P($G(^ICPT(ECVAL,0)),U)
..;get rid of the cpt record
..K ^TMP("PXKENC",$J,ECVIS,"CPT",ECREC)
.;get remaining cpt codes
.S ECREC=0,C=2
.F S ECREC=$O(^TMP("PXKENC",$J,ECVIS,"CPT",ECREC)) Q:'ECREC!(C>11) D
..S ECVAL=+^TMP("PXKENC",$J,ECVIS,"CPT",ECREC,0)
..I ECVAL S CPT(C)=$P($G(^ICPT(ECVAL,0)),U),C=C+1
;ao and ir
S (ECVAO,ECVIR)=""
I $D(^TMP("PXKENC",$J,ECVIS,"VST",ECVIS,800)) D
.S ECVAO=$P(^(800),U,2),ECVIR=$P(^(800),U,3)
.S:ECVAO="0" ECVAO="N" S:ECVIR=0 ECVIR="N"
.S:ECVAO="1" ECVAO="Y" S:ECVIR=1 ECVIR="Y"
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[HECXSCX 9901 printed Apr 09, 2024@20:59:24 Page 2
ECXSCX ;ALB/JAP,BIR/DMA,CML,PTD-Clinic Extract ; 02/06/97 10:24 [ 03/26/97 2:10 PM ]
+1 ;;3.0;DSS EXTRACTS;**1,3,11,8,13,14,28**;Dec 22, 1997
BEG ;entry point from option
+1 DO SETUP
IF ECFILE=""
QUIT
+2 DO ^ECXTRAC
DO ^ECXKILL
+3 QUIT
+4 ;
START ;entry point
+1 NEW QFLG,TIU
+2 ;get ien for tiu in file #839.7
+3 SET DIC="^PX(839.7,"
SET DIC(0)="X"
SET X="TEXT INTEGRATION UTILITIES"
DO ^DIC
SET TIU=0
if +Y>0
SET TIU=+Y
KILL DIC,Y
+4 KILL ^TMP("ECXS",$JOB)
SET ECXMISS=10
SET ECED=ECED+.3
SET SC=0
SET QFLG=0
+5 ;scheduled appts. and appended ekgs: loop through the file (#44)
+6 FOR
SET SC=$ORDER(^SC(SC))
if ('SC)!(QFLG)
QUIT
IF $DATA(^(SC,0))
SET EC=^(0)
IF $PIECE(EC,U,3)="C"
SET ECSU=$PIECE(EC,U,15)
if 'ECSU
SET ECSU=1
DO FEEDER^ECXSCX1(SC,ECSD1,.P1,.P2,.P3,.ECST)
IF ECST'=6
SET ECD=ECSD1
Begin DoDot:1
+7 FOR
SET ECD=$ORDER(^SC(SC,"S",ECD))
if 'ECD
QUIT
if ECD>ECED
QUIT
if QFLG
QUIT
SET ECDA=0
FOR
SET ECDA=$ORDER(^SC(SC,"S",ECD,1,ECDA))
if 'ECDA
QUIT
IF $DATA(^(ECDA,0))
Begin DoDot:2
+8 ;for each patient appointment in the date range (skip cancellations), examine the APPOINTMENT multiple in the PATIENT file (#2)
+9 IF $SELECT('$DATA(^SC(SC,"S",ECD,1,ECDA,"C")):1,1:$PIECE(^("C"),U,3)]"")
SET PTADT=^(0)
SET DFN=$PIECE(PTADT,U)
IF $DATA(^DPT(+DFN,0))
IF $PIECE(PTADT,U,9)=""
IF $PIECE($GET(^DPT(DFN,"S",ECD,0)),U,2)'["C"
Begin DoDot:3
+10 DO PAT
DO AOIRPOW^ECXUTL(DFN,.ECXAIP)
+11 SET ECL=$PIECE(PTADT,U,2)
SET ECL=$$RJ^XLFSTR(ECL,3,0)
SET ECOB=$GET(^SC(SC,"S",ECD,1,ECDA,"OB"))]""
+12 ;don't continue with record creation if the clinic appointment can't be found in subfile 2.98
+13 if '$DATA(^DPT(DFN,"S",ECD,0))
QUIT
if $PIECE(^DPT(DFN,"S",ECD,0),U)'=SC
QUIT
+14 KILL EC2
SET EC2=^DPT(DFN,"S",ECD,0)
SET ECN=$SELECT($PIECE(EC2,U,2)="N":"N",$PIECE(EC2,U,2)="NA":"N",$PIECE(EC2,U,2)="NT":"Q",1:"0")
+15 SET ECIEN=$PIECE(EC2,U,20)
SET ECEKG=$PIECE(EC2,U,5)
+16 IF ECST'=3
SET ECFD=P1_P2_ECL_P3_ECN
SET ECO1=ECO1_U_ECFD_U_ECOB_U_SC
DO API
DO FILE
+17 IF ECST=3
SET ECFD=P1_"000"_ECL_P3_ECN
SET ECO1=ECO1_U_ECFD_U_ECOB_U_SC
DO API
DO FILE
+18 IF ECST=3
SET ECFD=P2_"000"_ECL_P3_ECN
SET ECO1=ECO1_U_ECFD_U_ECOB_U_SC
DO API
DO FILE
+19 ;check for appended visits for EKG (107); if regular appt. is a no-show, append is a no-show
+20 if 'ECEKG
QUIT
Begin DoDot:4
+21 SET $PIECE(ECODE,U,10,12)="1070000280000"_ECN_U_U
+22 SET EC7=$ORDER(^ECX(ECFILE,999999999),-1)
SET EC7=EC7+1
+23 SET $PIECE(ECODE,U,1)=EC7
+24 DO FILE2
End DoDot:4
End DoDot:3
End DoDot:2
if QFLG
QUIT
End DoDot:1
if QFLG
QUIT
+25 ;Dispositions, stand-alones, and appended lab and x-ray: loop through the file (#409.68) for date range
+26 SET ECD=ECSD1
+27 FOR
SET ECD=$ORDER(^SCE("B",ECD))
if 'ECD!(ECD>ECED)
QUIT
SET ECIEN=0
Begin DoDot:1
+28 FOR
SET ECIEN=$ORDER(^SCE("B",ECD,ECIEN))
if 'ECIEN
QUIT
Begin DoDot:2
+29 ;quit if no outpatient encounter zero node
+30 if '$DATA(^SCE(ECIEN,0))
QUIT
+31 ;fd=1>x-ray or lab record, fd=2>disposition, fd=0>stand-alone visit
+32 SET FD=0
SET NCNTR=^SCE(ECIEN,0)
SET STOP=$PIECE($GET(^DIC(40.7,+$PIECE(NCNTR,U,3),0)),U,2)
+33 SET ENELG=$PIECE($GET(^DIC(8,+$PIECE(NCNTR,U,13),0)),U,9)
IF ENELG
SET ENELG=$CHAR(ENELG+64)
+34 ;quit if no clinic stop code for encounter
+35 if 'STOP
QUIT
+36 ;clinic stop code equals 105 (x-ray) or 108 (lab)
+37 IF (STOP=105)!(STOP=108)
SET FD=1
DO BLD
QUIT
+38 ;quit if encounter not stop code addition or disposition
+39 IF ($PIECE(NCNTR,U,8)'=2)
IF ($PIECE(NCNTR,U,8)'=3)
QUIT
+40 ;originating process type equals disposition
+41 IF $PIECE(NCNTR,U,8)=3
SET FD=2
DO BLD
QUIT
+42 ;else originating process type equals stop code addition (stand-alone)
+43 ;quit if there is a parent encounter pointer.
+44 if $PIECE($GET(NCNTR),U,6)
QUIT
+45 DO BLD
End DoDot:2
if QFLG
QUIT
End DoDot:1
if QFLG
QUIT
+46 ;send missing clinic msg if needed
+47 if $DATA(^TMP("ECXS",$JOB))
DO EN^ECXSCX1
+48 KILL EC,EC1,EC2,ECA,ECCPT,ECCSC,ECD,ECDA,ECEKG,ECFD,ECICD,ECIEN,ECL,ECMN,ECN,ECO1,ECO2,ECOB,ECODE,ECPROV,ECPTPR,ECPTTM,ECREC,ECSC,ECST,ECSU,ECTS,ECVAL,ECVIS
+49 KILL C,CPT,DFN,ELIG,P1,P11,P2,P3,PTADT,SC,VAERR,VAIP,SEX,ADDR,STATE,CNTY,ENELG,PAYOR,SAI,ENR,MST,MSTEI
+50 QUIT
+51 ;
BLD ;build record from outpatient encounter
+1 SET DFN=+$PIECE(NCNTR,U,2)
SET LOC=$PIECE(NCNTR,U,4)
SET ECSU=1
if LOC
SET ECSU=$PIECE(^SC(LOC,0),U,15)
+2 if '$DATA(^DPT(DFN,0))
QUIT
+3 DO PAT
DO AOIRPOW^ECXUTL(DFN,.ECXAIP)
+4 SET P1=$$RJ^XLFSTR(STOP,3,0)
SET P2="000"
SET P3="0000"
SET ECST=1
+5 ;for x-ray and lab
+6 IF FD=1
SET ECO1=ECO1_U_P1_P2_"02800000"_U_U
DO API
DO FILE
QUIT
+7 ;for dispositions
+8 IF FD=2
SET ECO1=ECO1_U_P1_"47906000000"_U_U
DO API
DO FILE
QUIT
+9 ;for stand-alone visits
+10 IF FD=0
IF LOC
IF $DATA(^SC(LOC,0))
Begin DoDot:1
+11 SET SC=LOC
SET APTLEN=29
+12 DO FEEDER^ECXSCX1(SC,ECD,.P1,.P2,.P3,.ECST)
+13 IF ECST'=6
Begin DoDot:2
+14 DO API
+15 IF $DATA(^TMP("PXKENC",$JOB,ECVIS,"VST",ECVIS,812))
Begin DoDot:3
+16 SET ECXSRCE=$PIECE(^TMP("PXKENC",$JOB,ECVIS,"VST",ECVIS,812),U,3)
+17 IF ECXSRCE=TIU
SET APTLEN=+$PIECE($GET(^SC(SC,"SL")),U,1)
if APTLEN=0
SET APTLEN=29
End DoDot:3
+18 SET APTLEN=$TRANSLATE($JUSTIFY(APTLEN,3)," ","0")
+19 SET ECO1=ECO1_U_P1_P2_APTLEN_P3_"0"_U_U_SC
+20 DO FILE
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
FILE ;finish record setup
+1 ;node0
+2 ;facility^dfn^ssn^name^in/out status^day^feeder key^overbook^sc^mov #^treat spec^time^primary care team^
+3 ;primary care provider^provider^CPT code^ICD-9 code^dob^eligibility^vet^race^
+4 ;ao status^ao visit^ir status^ir visit^pow status^pow location^provider person class
+5 ;node1
+6 ;mpi^dss dept^sex^zip+4^pc provider npi^provider npi^encounter elig^mst status^mst indicator
+7 ;cpt2^cpt3^cpt4^cpt5^cpt6^cpt7^cpt8^cpt9^cpt10^cpt11^sharing payor^sharing insurance^enr location^state^county^pc prov person class
+8 SET EC7=$ORDER(^ECX(ECFILE,999999999),-1)
SET EC7=EC7+1
+9 SET ECODE=EC7_U_EC23
+10 SET ECODE=ECODE_U_ECO1
+11 SET $PIECE(ECODE,U,8)=ECA
SET ECODE=ECODE_U_ECMN_U_ECTS_U_$$ECXTIME^ECXUTL(ECD)_U_ECPTTM_U_ECPTPR_U_ECPROV_U_ECCPT_U_ECICD
+12 SET ECODE=ECODE_U_$$ECXDOB^ECXUTL(DOB)_U_ELIG_U_VET_U_RACE
+13 SET ECODE=ECODE_U_ECXAIP("AO")_U_ECVAO_U_ECXAIP("IR")_U_ECVIR_U_ECXAIP("POW")_U_ECXAIP("POWL")_U_ECXPRPC
+14 SET CPT=""
FOR C=2:1:11
SET CPT=CPT_CPT(C)
IF C<11
SET CPT=CPT_U
+15 SET ECODE1=U_U_SEX_U_ZIP_U_U_U_ENELG_U_MST_U_MSTEI_U_CPT_U_PAYOR_U_SAI_U_ENR_U_STATE_U_CNTY_U_ECCLAS
+16 DO CUT^ECXSCX1(.ECODE,.ECODE1)
+17 DO FILE2
+18 QUIT
+19 ;
FILE2 ;file record
+1 NEW DA,DIK
+2 SET ^ECX(ECFILE,EC7,0)=ECODE
SET ^ECX(ECFILE,EC7,1)=ECODE1
SET ECRN=ECRN+1
+3 SET DA=EC7
SET DIK="^ECX("_ECFILE_","
DO IX^DIK
KILL DIK,DA
+4 IF $DATA(ZTQUEUED)
IF ECRN>499
IF '(ECRN#500)
IF $$S^%ZTLOAD
SET QFLG=1
+5 QUIT
+6 ;
SETUP ;Set required input for ECXTRAC
+1 SET ECHEAD="CLI"
+2 DO ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+3 QUIT
+4 ;
PAT ;patient file data
+1 NEW VAPA
+2 SET EC1=^DPT(DFN,0)
+3 SET ECO1=ECSU_U_DFN_U_$PIECE(EC1,U,9)_U_$EXTRACT($PIECE($PIECE(EC1,U),",")_" ",1,4)_U_U_$$ECXDATE^ECXUTL(ECD,ECXYM)
+4 SET ELIG=$PIECE($GET(^DIC(8,+$GET(^DPT(DFN,.36)),0)),U,9)
IF ELIG
SET ELIG=$CHAR(ELIG+64)
+5 SET SEX=$PIECE(EC1,U,2)
SET DOB=$PIECE(EC1,U,3)
SET VET=$PIECE($GET(^DPT(DFN,"VET")),U)
SET RACE=$PIECE($GET(^DIC(10,+$PIECE(EC1,U,6),0)),U,2)
+6 DO ADD^VADPT
+7 SET STATE=VAPA(5)
SET CNTY=VAPA(7)
SET ZIP=$PIECE(VAPA(11),U,2)
+8 SET STATE=$PIECE($GET(^DIC(5,+STATE,0)),U,3)
SET CNTY=$PIECE($GET(^DIC(5,+STATE,1,+CNTY,0)),U,3)
+9 SET ENR=$PIECE($GET(^DPT(DFN,"ENR")),U,2)
IF ENR
Begin DoDot:1
+10 SET DIC="^DIC(4,"
SET DA=ENR
SET DR="99;"
SET DIQ(0)="I"
SET DIQ="ENR"
+11 DO EN^DIQ1
SET ENR=ENR(4,ENR,99,"I")
+12 KILL DIC,DIQ,DA,DR
End DoDot:1
+13 SET (MST,MSTEI)=""
+14 ;get visn 19 sharing agreement data
+15 DO VISN19^ECXUTL2(DFN,.PAYOR,.SAI)
+16 QUIT
API ;call external utilities
+1 ;determine in/out status and primary care
+2 NEW X,PROV
+3 FOR C=2:1:11
SET CPT(C)=""
+4 SET X=$$INP^ECXUTL2(DFN,ECD)
SET ECA=$PIECE(X,U,1)
SET ECMN=$PIECE(X,U,2)
SET ECTS=$PIECE(X,U,3)
+5 SET X=$$PRIMARY^ECXUTL2(DFN,ECD)
SET ECPTTM=$PIECE(X,U,1)
SET ECPTPR=$PIECE(X,U,2)
SET ECCLAS=$PIECE(X,U,3)
+6 ;call pce api for cpt code, diagnosis/provider designated as primary
+7 SET ENELG=""
SET ECPROV=""
SET ECXPRPC=""
SET ECCPT=99199
SET ECICD=799.9
SET ECVAO=""
SET ECVIR=""
+8 IF 'ECIEN
QUIT
+9 IF ECIEN
Begin DoDot:1
+10 SET ECVIS=+$PIECE($GET(^SCE(ECIEN,0)),U,5)
+11 SET ENELG=+$PIECE($GET(^SCE(ECIEN,0)),U,13)
SET ENELG=$PIECE($GET(^DIC(8,ENELG,0)),U,9)
+12 IF ENELG
SET ENELG=$CHAR(ENELG+64)
End DoDot:1
+13 IF 'ECVIS
QUIT
+14 IF ECVIS
DO ENCEVENT^PXAPI(ECVIS)
+15 IF $ORDER(^TMP("PXKENC",$JOB,ECVIS,""))']""
QUIT
+16 ;get icd9 code; else use 799.9
+17 IF $ORDER(^TMP("PXKENC",$JOB,ECVIS,"POV",0))
Begin DoDot:1
+18 SET (ECREC,ECVAL)=0
+19 FOR
SET ECREC=$ORDER(^TMP("PXKENC",$JOB,ECVIS,"POV",ECREC))
if 'ECREC
QUIT
if ($PIECE(^TMP("PXKENC",$JOB,ECVIS,"POV",ECREC,0),U,12)="P")
SET ECVAL=+^(0)
if $PIECE(^TMP("PXKENC",$JOB,ECVIS,"POV",ECREC,0),U,12)="P"
QUIT
+20 IF 'ECVAL
SET ECREC=$ORDER(^TMP("PXKENC",$JOB,ECVIS,"POV",0))
IF ECREC
SET ECVAL=+^(ECREC,0)
+21 IF ECVAL
SET ECICD=$PIECE($GET(^ICD9(ECVAL,0)),U)
End DoDot:1
+22 ;get first provider designated as primary; if no primary, then get first physician provider; if no physician, then get first provider; if no "prv" array nodes, use null.
+23 IF $ORDER(^TMP("PXKENC",$JOB,ECVIS,"PRV",0))
Begin DoDot:1
+24 SET (ECREC,ECVAL)=0
+25 FOR
SET ECREC=$ORDER(^TMP("PXKENC",$JOB,ECVIS,"PRV",ECREC))
if 'ECREC
QUIT
if ($PIECE(^TMP("PXKENC",$JOB,ECVIS,"PRV",ECREC,0),U,4)="P")
SET ECVAL=+^(0)
if $PIECE(^TMP("PXKENC",$JOB,ECVIS,"PRV",ECREC,0),U,4)="P"
QUIT
+26 IF ECVAL
SET ECPROV=ECVAL
SET ECXPRPC=$$PRVCLASS^ECXUTL(ECPROV,ECD)
+27 IF 'ECVAL
SET ECREC=0
Begin DoDot:2
+28 FOR
SET ECREC=$ORDER(^TMP("PXKENC",$JOB,ECVIS,"PRV",ECREC))
if 'ECREC
QUIT
Begin DoDot:3
+29 SET ECVAL=+^TMP("PXKENC",$JOB,ECVIS,"PRV",ECREC,0)
if 'ECVAL
QUIT
+30 SET ECXPRPC=$$PRVCLASS^ECXUTL(ECVAL,ECD)
if ECXPRPC=""
QUIT
+31 SET NUM=$EXTRACT(ECXPRPC,2,7)
if (NUM<110000)!(NUM>119999)
SET ECVAL=0
SET ECXPRPC=""
+32 IF ECVAL
SET ECPROV=ECVAL
End DoDot:3
if ECVAL
QUIT
End DoDot:2
+33 IF 'ECVAL
Begin DoDot:2
+34 SET ECREC=$ORDER(^TMP("PXKENC",$JOB,ECVIS,"PRV",0))
if 'ECREC
QUIT
SET ECVAL=+^(ECREC,0)
+35 IF ECVAL
SET ECPROV=ECVAL
SET ECXPRPC=$$PRVCLASS^ECXUTL(ECPROV,ECD)
End DoDot:2
+36 if ECPROV]""
SET ECPROV="2"_ECPROV
End DoDot:1
+37 ;get cpt code for ien
+38 IF $ORDER(^TMP("PXKENC",$JOB,ECVIS,"CPT",0))
Begin DoDot:1
+39 SET (ECREC,ECVAL)=0
+40 ;if there's a primary provider, get a cpt associated with that provider
+41 IF ECPROV]""
Begin DoDot:2
+42 SET PROV=$EXTRACT(ECPROV,2,99)
+43 FOR
SET ECREC=$ORDER(^TMP("PXKENC",$JOB,ECVIS,"CPT",ECREC))
if 'ECREC
QUIT
Begin DoDot:3
+44 IF $DATA(^TMP("PXKENC",$JOB,ECVIS,"CPT",ECREC,12))
if $PIECE(^(12),U,4)=PROV
SET ECVAL=+^TMP("PXKENC",$JOB,ECVIS,"CPT",ECREC,0)
+45 IF ECVAL
Begin DoDot:4
+46 SET ECCPT=$PIECE($GET(^ICPT(ECVAL,0)),U)
End DoDot:4
+47 ;get rid of the cpt record
+48 KILL ^TMP("PXKENC",$JOB,ECVIS,"CPT",ECREC)
End DoDot:3
if ECVAL
QUIT
End DoDot:2
+49 IF ECVAL=0
SET ECREC=+$ORDER(^TMP("PXKENC",$JOB,ECVIS,"CPT",0))
IF ECREC
SET ECVAL=+^(ECREC,0)
+50 IF ECVAL
Begin DoDot:2
+51 SET ECCPT=$PIECE($GET(^ICPT(ECVAL,0)),U)
+52 ;get rid of the cpt record
+53 KILL ^TMP("PXKENC",$JOB,ECVIS,"CPT",ECREC)
End DoDot:2
+54 ;get remaining cpt codes
+55 SET ECREC=0
SET C=2
+56 FOR
SET ECREC=$ORDER(^TMP("PXKENC",$JOB,ECVIS,"CPT",ECREC))
if 'ECREC!(C>11)
QUIT
Begin DoDot:2
+57 SET ECVAL=+^TMP("PXKENC",$JOB,ECVIS,"CPT",ECREC,0)
+58 IF ECVAL
SET CPT(C)=$PIECE($GET(^ICPT(ECVAL,0)),U)
SET C=C+1
End DoDot:2
End DoDot:1
+59 ;ao and ir
+60 SET (ECVAO,ECVIR)=""
+61 IF $DATA(^TMP("PXKENC",$JOB,ECVIS,"VST",ECVIS,800))
Begin DoDot:1
+62 SET ECVAO=$PIECE(^(800),U,2)
SET ECVIR=$PIECE(^(800),U,3)
+63 if ECVAO="0"
SET ECVAO="N"
if ECVIR=0
SET ECVIR="N"
+64 if ECVAO="1"
SET ECVAO="Y"
if ECVIR=1
SET ECVIR="Y"
End DoDot:1
+65 QUIT
+66 ;
QUE ;entry point for the background requeuing handled by ECXTAUTO
+1 DO SETUP
DO QUE^ECXTAUTO
DO ^ECXKILL
QUIT
