ECXPIVDN ;ALB/JAP,BIR/DMA,CML,PTD-Extract from IV EXTRACT DATA File (#728.113) ;5/13/19 11:25
;;3.0;DSS EXTRACTS;**10,11,8,13,24,33,39,46,49,71,84,96,92,107,105,112,120,127,136,143,144,149,166,170,174,181,184,187,190**;Dec 22, 1997;Build 36
;
; Reference to ^TMP($J in SACC 2.3.2.5.1
; Reference to $$LJ^XLFSTR in ICR #10104
; Reference to $$DSS^PSNAPIS in ICR #2531
; Reference to $$NPI^XUSNPI in ICR #4532
;
BEG ;entry point from option
D SETUP I ECFILE="" Q
D ^ECXTRAC,^ECXKILL
Q
;
START ; start package specific extract
N DIC,DA,DR,DIQ,DFN,ECXNPRFI,ECXPHA,ECXESC,ECXECL,ECXCLST,ECXDEA ;144,174
N ECXSTANO ;166
S QFLG=0
I '$D(ECINST) D
.S ECINST=+$P(^ECX(728,1,0),U) K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
.D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
S ECED=ECED+.3
K ^TMP($J,"A"),^TMP($J,"S")
S ECD=ECSD1
F S ECD=$O(^ECX(728.113,"A",ECD)),DFN=0 Q:'ECD Q:ECD>ECED Q:QFLG F S DFN=$O(^ECX(728.113,"A",ECD,DFN)),ON=0 Q:'DFN F S ON=$O(^ECX(728.113,"A",ECD,DFN,ON)),DA=0 Q:'ON K ^TMP($J,"A"),^TMP($J,"S") S ECVOL=0 D Q:QFLG
.F S DA=$O(^ECX(728.113,"A",ECD,DFN,ON,DA)) Q:'DA Q:QFLG I $D(^ECX(728.113,DA,0)) S EC=^(0) D Q:QFLG
..S DRG=$P(EC,U,4) I $P(EC,U,8)]"" D
...I '$D(^TMP($J,"A",DRG)) S ^(DRG)=$P(EC,U,7,8),^(DRG,1)=0,^(2)=$P(EC,U,12)
...S ^(1)=^TMP($J,"A",DRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:-1,1:-1) ; 187 deduct 1 from the count if transaction type is 4 (canceled)
..I $P(EC,U,9) D
...I '$D(^TMP($J,"S",DRG)) S ^(DRG)=$P(EC,U,9)_"^ML",^(DRG,1)=0,^(2)=$P(EC,U,12),ECVOL=$P(EC,U,9)+ECVOL
...S ^(1)=^TMP($J,"S",DRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:-1,1:-1) ;187 deduct 1 from the count if transaction type is 4 (canceled)
..S ECTYP=$P(EC,U,11),ECTOTC=0,ECDTTM=$$ECXTIME^ECXUTL($P(EC,U,5))
.;looped thru all DAs for this order - now put it together
.;leave the next line in case the decision is made to send volume designations
.;I ECTYP="H" S ECTYP=ECTYP_$S(ECVOL'>1000:1,ECVOL'>2000:2,1:3)
.S ECXDSSI=""
.;loop thru tmp global and call pharmacy drug file (#50) api
.F SA="S","A" S DRG="" F S DRG=$O(^TMP($J,SA,DRG)) Q:DRG="" S ECXPHA="",ECXPHA=$$PHAAPI^ECXUTL5(DRG) I ($P(ECXPHA,U)'=""),$G(^TMP($J,SA,DRG,1))>0 D STUFF Q:QFLG ;187 - Exclude records that have 0 quantity.
I $D(^TMP($J,"ECXIVPM")) D SENDMSG^ECXPIVD2 ;181 - Send messages with list of clinics with NO/Inactive Stop Code
K ^TMP($J),CLIN,DA,DFN,DIC,DIK,DRG,ON,SA,X,Y,P1,P3
Q
STUFF ;get data
N ECORDST,ECXASIH ;170
N ECXCERN,ECXNMPI,ECXSIGI ;184 New fields added
N ECXDUNIT,ECXPPDU ;187 Added Dispense Unit and Price Per Dispense Unit
S ECXERR=0 D PAT(DFN,$P(EC,U,5),.ECXERR) ;166 get patient information
Q:ECXERR ;166 Quit if issue with patient
S ECST=^TMP($J,SA,DRG),ECXCNT=^(DRG,1),ECXCOST=^(2),ECVACL=$P(ECXPHA,U,2),ECORDST=""
I ECXLOGIC>2024 S ECXDUNIT=$P(ECST,U,2) ;190
;if older logic, use incorrect calculation for cost **136
I ECXLOGIC<2013 S ECXCOST=ECXCOST*ECXCNT
;S ECST=^TMP($J,SA,DRG),ECXCNT=^(DRG,1),ECXCOST=^(2),ECXCOST=ECXCOST*ECXCNT,ECVACL=$P(ECXPHA,U,2),ECORDST="",ECTI="" removed old cost calc **136
;if outpatient get division from iv rm; get dss identifier for clinic
I ECXA="O" D
.;- Only set ward to .5 if outpatient (but NOT observation patient)
.I $G(ECXW)="" S ECXW=.5
.I $P(EC,U,15) S ECIVRM=$P(EC,U,15),ECXDIV=$$PSJ59P5^ECXUTL5(ECIVRM)
.S CLIN=+$P(EC,U,13),(ECXP1,ECXP2)="000",ECXCL=$G(^ECX(728.44,CLIN,0)) Q:ECXCL=""
.S ECSC=$P(ECXCL,U,4),ECCSC=$P(ECXCL,U,5)
.I ECSC="" S ECSC=$P(ECXCL,U,2),ECCSC=$P(ECXCL,U,3)
.I ECSC S ECXP1=$$RJ^XLFSTR(ECSC,3,0),ECXP2=$$RJ^XLFSTR(ECCSC,3,0)
.I ECSC="" S ECSC=$P($G(^SC(ECXCL,0)),U,7),ECCSC=$P($G(^SC(ECXCL,0)),U,18) I ECSC D
..S ECXP1=$P($G(^DIC(40.7,ECSC,0)),U,2) S:ECCSC]"" ECXP2=$P($G(^DIC(40.7,ECCSC,0)),U,2)
..S ECXP1=$$RJ^XLFSTR(ECXP1,3,0),ECXP2=$$RJ^XLFSTR(ECXP2,3,0)
.S ECXDSSI=ECXP1_ECXP2
.I ECXLOGIC>2003 D
..I "^18^23^24^41^65^94^108^"[("^"_ECXTS_"^") S ECXDSSI=$$TSMAP^ECXUTL4(ECXTS)
S (ECINV,ECXDEA)=$P(ECXPHA,U,4),ECST=ECXCNT*ECST_" "_$P(ECST,U,2) ;174
;New way to calculate cost dea spl hndlg **136 upd precedence **144
I ECXLOGIC>2012 S ECINV=$S((+ECINV>0)&(+ECINV<6):+ECINV,ECINV["I":"I",1:"") D
.; Update cost calculation use exist cost x quant x count
.S ECXCOST=+ECST*ECXCOST ;143
; old method of dea spl hndlg **136
I ECXLOGIC<2013 S ECINV=$S(ECINV["I":"I",1:"")
S ECNDC=$P(ECXPHA,U,3),ECNFC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNFC=$TR(ECNFC,"*",0)
I ECNDC["LCL"!(ECNDC["LCD") S ECNDC="" ;170,174 Reset NDC to null if it's missing from file 50
S P1=$P(ECXPHA,U,5),P3=$P(ECXPHA,U,6)
S X="PSNAPIS" X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC
I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC
;- Ordering provider ("2"_provider)
S ECXORDPR=$S(+$P(EC,U,10):"2"_$P(EC,U,10),1:"")
N ECXUSRTN
S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",$P(EC,U,10),$P(EC,U,16))
S:+ECXUSRTN'>0 ECXUSRTN="" S ECXOPNPI=$P(ECXUSRTN,U)
S ECXORDDT=$P(EC,U,16) ;- Ordering date
;- Requesting physician (null for FY2002)
S ECXRPHY=""
;- Department and National Prod Division
S ECXDSSD="" ;dss department use postponed $$IVP^ECXDEPT(ECXDIV)
N ECXPDIV S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV)
I ECXA="O" S ECXSTANO=ECXPDIV ;tjl 166 For outpatients, set Station Number to Prod Div Code
;- Observation patient indicator (yes/no)
S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXDSSI)
; - Ordering Date, Ordering Stop Code
S ECXORDST="" S:ECXA="O" ECXORDST=$$DOIVPO^ECXUTL5(DFN,ON) S ECORDST=ECXORDST ;170
I $P(ECXORDST,U,2)'="" D ;181 - No/Inactive Stop Code, default to PHA. Save information to send mail later
.D SETTMP(ECXORDST)
.S (ECORDST,ECXORDST)="PHA"
;- If no encounter number don't file record
S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADM,ECD,ECXTS,ECXOBS,ECHEAD,ECORDST,)
S (ECXBCDD,ECXBCDG,ECXBCUA,ECXBCIF)="" ;144 BCMA fields are place holder now
;get ordering provider person class
S ECXOPPC=$$PRVCLASS^ECXUTL($E(ECXORDPR,2,999),ECXORDDT)
;set national patient record flag if exist
S ECXDFN=DFN D NPRF^ECXUTL5 K ECXDFN
I $G(ECXASIH) S ECXA="A" ;170
S:ECXDUNIT']"" ECXDUNIT=$P(ECXPHA,U,8) S ECXPPDU=$P(ECXPHA,U,7) ;187,190
D:ECXENC'="" FILE^ECXPIVD2 K P1,P3
Q
PAT(ECXDFN,ECXDATE,ECXERR) ;get patient demographics, primary care, and inpatient data
N X
;N ECXNMPI,ECXCERN,ECXSIGI ;184 - Fields added
S ECXCERN="" ;184
S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP,ECXOEF,ECXOEFDT)=""
;get patient data if saved
I $D(^TMP($J,"ECXP",ECXDFN)) D
.S PT=^TMP($J,"ECXP",ECXDFN),ECXPNM=$P(PT,U),ECXSSN=$P(PT,U,2),(ECXNMPI,ECXMPI)=$P(PT,U,3) ;184 Added ECXNMPI
.S ECXDOB=$P(PT,U,4),ECXELIG=$P(PT,U,5),ECXSEX=$P(PT,U,6),ECXSTATE=$P(PT,U,7),ECXCNTY=$P(PT,U,8),ECXZIP=$P(PT,U,9)
.S ECXVET=$P(PT,U,10),ECXPOS=$P(PT,U,11),ECXPST=$P(PT,U,12),ECXPLOC=$P(PT,U,13),ECXRST=$P(PT,U,14),ECXAST=$P(PT,U,15)
.S ECXAOL=$P(PT,U,16),ECXPHI=$P(PT,U,17),ECXMST=$P(PT,U,18),ECXENRL=$P(PT,U,19),ECXCNHU=$P(PT,U,20),ECXCAT=$P(PT,U,21)
.S ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23),ECXHNCI=$P(PT,U,24),ECXETH=$P(PT,U,25),ECXRC1=$P(PT,U,26),ECXMTST=$P(PT,U,27)
.S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2),ECXOEF=$P(PT1,U,3),ECXOEFDT=$P(PT1,U,4),ECXCNTRY=$P(PT1,U,5)
.S ECXSHADI=$P(PT1,U,6),ECXPATCAT=$P(PT1,U,7)
.S ECXCLST=$P(PT1,U,8),ECXESC=$P(PT1,U,9),ECXECL=$P(PT1,U,10) ;144
.S ECXSIGI=$P(PT1,U,13) ;184 Self Identified Gender
.I $$ENROLLM^ECXUTL2(ECXDFN)
;set patient data
I '$D(^TMP($J,"ECXP",ECXDFN)) D Q:'OK
.K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;5",.ECXPAT)
.I 'OK K ECXPAT S ECXERR=1 Q
.S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),(ECXNMPI,ECXMPI)=ECXPAT("MPI"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG"),ECXSEX=ECXPAT("SEX") ;184 - Added ECXNMPI
.S ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP"),ECXVET=ECXPAT("VET"),ECXCNTRY=ECXPAT("COUNTRY")
.S ECXPOS=ECXPAT("POS"),ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT")
.S ECXAST=ECXPAT("AO STAT"),ECXAOL=ECXPAT("AOL"),ECXPHI=ECXPAT("PHI"),ECXMST=ECXPAT("MST STAT")
.S ECXCLST=ECXPAT("CL STAT"),ECXESC="",ECXECL="" ;144
.S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS"),ECXEST=ECXPAT("EC STAT")
.S ECXSVCI=ECXPAT("COMBSVCI"),ECXSVCL=ECXPAT("COMBSVCL") ;149 COMBAT SVC LOC
.S ECXSIGI=ECXPAT("SIGI") ;184 Self Idenfied Gender
.S ECXCNHU=$$CNHSTAT^ECXUTL4(ECXDFN) ;get CNHU status
.;get enrollment data (category, status and priority)
.I $$ENROLLM^ECXUTL2(ECXDFN)
.S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) ;Head and Neck Cancer Indicator
.S ECXSHADI=$$SHAD^ECXUTL4(ECXDFN) ;PROJ 112/SHAD Indicator
.S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN) ; PATCH 127, ADD PATCAT CODE
.; - Race and Ethnicity
.S ECXETH=ECXPAT("ETHNIC"),ECXRC1=ECXPAT("RACE1")
.S ECXERI=ECXPAT("ERI") ;emergency response indicator (FEMA)
.S ECXOEF=ECXPAT("ECXOEF")
.S ECXOEFDT=ECXPAT("ECXOEFDT")
.;save for later
.S ^TMP($J,"ECXP",ECXDFN)=ECXPNM_U_ECXSSN_U_ECXMPI_U_ECXDOB_U_ECXELIG_U_ECXSEX_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST
.S ^TMP($J,"ECXP",ECXDFN)=^TMP($J,"ECXP",ECXDFN)_U_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXENRL_U_ECXCNHU_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXHNCI_U_ECXETH_U_ECXRC1_U_ECXMTST
.S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST_U_ECXOEF_U_ECXOEFDT_U_ECXCNTRY_U_ECXSHADI_U_ECXPATCAT_U_ECXCLST_U_ECXESC_U_ECXECL_U_ECXSVCI_U_ECXSVCL ;149
.S ^TMP($J,"ECXP",ECXDFN,1)=^TMP($J,"ECXP",ECXDFN,1)_U_ECXSIGI ;184
;get primary care data
S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,"."))
S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
;get inpatient data
S (ECXA,ECXMN,ECXADM,ECXTS,ECXW,ECXDIV)="",X=$$INP^ECXUTL2(ECXDFN,ECXDATE)
S ECXA=$P(X,U),ECXMN=$P(X,U,2),ECXTS=$P(X,U,3),ECXADM=$P(X,U,4),W=$P(X,U,9),ECXDOM=$P(X,U,10),ECXW=$P(W,";"),ECXDIV=$P(W,";",2),ECXASIH=$P(X,U,14) ;170
I ECXA="I" S ECXSTANO=$$GETDIV^ECXDEPT(ECXDIV) ;tjl 166 For inpatients, get Station Number based on Ward
Q
SETUP ;Set required input for ECXTRAC
S ECHEAD="IVP"
D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
;variables ecver and ecrtn will be reset in routine ecxtrac if appropriate
S ECVER=7
Q
QUE ; entry point for the background requeuing handled by ECXTAUTO
D SETUP,QUE^ECXTAUTO,^ECXKILL Q
;
SETTMP(STR) ;181 - Set global TMP for Mail Message
N CLIN,SCODE,DIC,ECXDIC,ECXDICA,ECXNOSC,ECXINVSC,DIQ,DR,DA
I $P(STR,U,2)="MISSING STOP CODE" D Q
.S CLIN=$P(STR,U)
.I $D(^TMP($J,"ECXIVPM","NOSC",CLIN)) Q
.I '$D(^TMP($J,"ECXIVPM","ECXNOSC")) S ^TMP($J,"ECXIVPM","ECXNOSC")=0
.S ECXNOSC=^TMP($J,"ECXIVPM","ECXNOSC")+1
.S DIC="^SC(",DIQ="IE",DIQ="ECXDIC",DR=".01",DA=CLIN D EN^DIQ1
.S ^TMP($J,"ECXIVPM","ECXNOSC",ECXNOSC,0)=$J(CLIN,8)_" "_$$LJ^XLFSTR(ECXDIC(44,CLIN,.01),32)
.S ^TMP($J,"ECXIVPM","ECXNOSC")=ECXNOSC
.S ^TMP($J,"ECXIVPM","NOSC",CLIN)=""
I $P(STR,U,2)="INVALID STOP CODE" D
.S CLIN=$P(STR,U),SCODE=$P(STR,U,3)
.I $D(^TMP($J,"ECXIVPM","INVSC",CLIN)) Q
.I '$D(^TMP($J,"ECXIVPM","ECXINVSC")) S ^TMP($J,"ECXIVPM","ECXINVSC")=0
.S ECXINVSC=^TMP($J,"ECXIVPM","ECXINVSC")+1
.S DIC="^SC(",DIQ="IE",DIQ="ECXDIC",DR=".01",DA=CLIN D EN^DIQ1
.S DIC="^DIC(40.7,",DIQ(0)="E",DIQ="ECXDICA",DR=".01;1;2",DA=SCODE D EN^DIQ1
.S ^TMP($J,"ECXIVPM","ECXINVSC",ECXINVSC,0)=$J(CLIN,8)_"/"_$$LJ^XLFSTR(ECXDIC(44,CLIN,.01),25)_" "_$J(ECXDICA(40.7,SCODE,1,"E"),8)_"/"_$$LJ^XLFSTR(ECXDICA(40.7,SCODE,.01,"E"),25)
.S ^TMP($J,"ECXIVPM","ECXINVSC")=ECXINVSC
.S ^TMP($J,"ECXIVPM","INVSC",CLIN)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXPIVDN 11746 printed Dec 13, 2024@01:53:28 Page 2
ECXPIVDN ;ALB/JAP,BIR/DMA,CML,PTD-Extract from IV EXTRACT DATA File (#728.113) ;5/13/19 11:25
+1 ;;3.0;DSS EXTRACTS;**10,11,8,13,24,33,39,46,49,71,84,96,92,107,105,112,120,127,136,143,144,149,166,170,174,181,184,187,190**;Dec 22, 1997;Build 36
+2 ;
+3 ; Reference to ^TMP($J in SACC 2.3.2.5.1
+4 ; Reference to $$LJ^XLFSTR in ICR #10104
+5 ; Reference to $$DSS^PSNAPIS in ICR #2531
+6 ; Reference to $$NPI^XUSNPI in ICR #4532
+7 ;
BEG ;entry point from option
+1 DO SETUP
IF ECFILE=""
QUIT
+2 DO ^ECXTRAC
DO ^ECXKILL
+3 QUIT
+4 ;
START ; start package specific extract
+1 ;144,174
NEW DIC,DA,DR,DIQ,DFN,ECXNPRFI,ECXPHA,ECXESC,ECXECL,ECXCLST,ECXDEA
+2 ;166
NEW ECXSTANO
+3 SET QFLG=0
+4 IF '$DATA(ECINST)
Begin DoDot:1
+5 SET ECINST=+$PIECE(^ECX(728,1,0),U)
KILL ECXDIC
SET DA=ECINST
SET DIC="^DIC(4,"
SET DIQ(0)="I"
SET DIQ="ECXDIC"
SET DR=".01;99"
+6 DO EN^DIQ1
SET ECINST=$GET(ECXDIC(4,DA,99,"I"))
KILL DIC,DIQ,DA,DR,ECXDIC
End DoDot:1
+7 SET ECED=ECED+.3
+8 KILL ^TMP($JOB,"A"),^TMP($JOB,"S")
+9 SET ECD=ECSD1
+10 FOR
SET ECD=$ORDER(^ECX(728.113,"A",ECD))
SET DFN=0
if 'ECD
QUIT
if ECD>ECED
QUIT
if QFLG
QUIT
FOR
SET DFN=$ORDER(^ECX(728.113,"A",ECD,DFN))
SET ON=0
if 'DFN
QUIT
FOR
SET ON=$ORDER(^ECX(728.113,"A",ECD,DFN,ON))
SET DA=0
if 'ON
QUIT
KILL ^TMP($JOB,"A"),^TMP($JOB,"S")
SET ECVOL=0
Begin DoDot:1
+11 FOR
SET DA=$ORDER(^ECX(728.113,"A",ECD,DFN,ON,DA))
if 'DA
QUIT
if QFLG
QUIT
IF $DATA(^ECX(728.113,DA,0))
SET EC=^(0)
Begin DoDot:2
+12 SET DRG=$PIECE(EC,U,4)
IF $PIECE(EC,U,8)]""
Begin DoDot:3
+13 IF '$DATA(^TMP($JOB,"A",DRG))
SET ^(DRG)=$PIECE(EC,U,7,8)
SET ^(DRG,1)=0
SET ^(2)=$PIECE(EC,U,12)
+14 ; 187 deduct 1 from the count if transaction type is 4 (canceled)
SET ^(1)=^TMP($JOB,"A",DRG,1)+$SELECT($PIECE(EC,U,6)=1:1,$PIECE(EC,U,6)=4:-1,1:-1)
End DoDot:3
+15 IF $PIECE(EC,U,9)
Begin DoDot:3
+16 IF '$DATA(^TMP($JOB,"S",DRG))
SET ^(DRG)=$PIECE(EC,U,9)_"^ML"
SET ^(DRG,1)=0
SET ^(2)=$PIECE(EC,U,12)
SET ECVOL=$PIECE(EC,U,9)+ECVOL
+17 ;187 deduct 1 from the count if transaction type is 4 (canceled)
SET ^(1)=^TMP($JOB,"S",DRG,1)+$SELECT($PIECE(EC,U,6)=1:1,$PIECE(EC,U,6)=4:-1,1:-1)
End DoDot:3
+18 SET ECTYP=$PIECE(EC,U,11)
SET ECTOTC=0
SET ECDTTM=$$ECXTIME^ECXUTL($PIECE(EC,U,5))
End DoDot:2
if QFLG
QUIT
+19 ;looped thru all DAs for this order - now put it together
+20 ;leave the next line in case the decision is made to send volume designations
+21 ;I ECTYP="H" S ECTYP=ECTYP_$S(ECVOL'>1000:1,ECVOL'>2000:2,1:3)
+22 SET ECXDSSI=""
+23 ;loop thru tmp global and call pharmacy drug file (#50) api
+24 ;187 - Exclude records that have 0 quantity.
FOR SA="S","A"
SET DRG=""
FOR
SET DRG=$ORDER(^TMP($JOB,SA,DRG))
if DRG=""
QUIT
SET ECXPHA=""
SET ECXPHA=$$PHAAPI^ECXUTL5(DRG)
IF ($PIECE(ECXPHA,U)'="")
IF $GET(^TMP($JOB,SA,DRG,1))>0
DO STUFF
if QFLG
QUIT
End DoDot:1
if QFLG
QUIT
+25 ;181 - Send messages with list of clinics with NO/Inactive Stop Code
IF $DATA(^TMP($JOB,"ECXIVPM"))
DO SENDMSG^ECXPIVD2
+26 KILL ^TMP($JOB),CLIN,DA,DFN,DIC,DIK,DRG,ON,SA,X,Y,P1,P3
+27 QUIT
STUFF ;get data
+1 ;170
NEW ECORDST,ECXASIH
+2 ;184 New fields added
NEW ECXCERN,ECXNMPI,ECXSIGI
+3 ;187 Added Dispense Unit and Price Per Dispense Unit
NEW ECXDUNIT,ECXPPDU
+4 ;166 get patient information
SET ECXERR=0
DO PAT(DFN,$PIECE(EC,U,5),.ECXERR)
+5 ;166 Quit if issue with patient
if ECXERR
QUIT
+6 SET ECST=^TMP($JOB,SA,DRG)
SET ECXCNT=^(DRG,1)
SET ECXCOST=^(2)
SET ECVACL=$PIECE(ECXPHA,U,2)
SET ECORDST=""
+7 ;190
IF ECXLOGIC>2024
SET ECXDUNIT=$PIECE(ECST,U,2)
+8 ;if older logic, use incorrect calculation for cost **136
+9 IF ECXLOGIC<2013
SET ECXCOST=ECXCOST*ECXCNT
+10 ;S ECST=^TMP($J,SA,DRG),ECXCNT=^(DRG,1),ECXCOST=^(2),ECXCOST=ECXCOST*ECXCNT,ECVACL=$P(ECXPHA,U,2),ECORDST="",ECTI="" removed old cost calc **136
+11 ;if outpatient get division from iv rm; get dss identifier for clinic
+12 IF ECXA="O"
Begin DoDot:1
+13 ;- Only set ward to .5 if outpatient (but NOT observation patient)
+14 IF $GET(ECXW)=""
SET ECXW=.5
+15 IF $PIECE(EC,U,15)
SET ECIVRM=$PIECE(EC,U,15)
SET ECXDIV=$$PSJ59P5^ECXUTL5(ECIVRM)
+16 SET CLIN=+$PIECE(EC,U,13)
SET (ECXP1,ECXP2)="000"
SET ECXCL=$GET(^ECX(728.44,CLIN,0))
if ECXCL=""
QUIT
+17 SET ECSC=$PIECE(ECXCL,U,4)
SET ECCSC=$PIECE(ECXCL,U,5)
+18 IF ECSC=""
SET ECSC=$PIECE(ECXCL,U,2)
SET ECCSC=$PIECE(ECXCL,U,3)
+19 IF ECSC
SET ECXP1=$$RJ^XLFSTR(ECSC,3,0)
SET ECXP2=$$RJ^XLFSTR(ECCSC,3,0)
+20 IF ECSC=""
SET ECSC=$PIECE($GET(^SC(ECXCL,0)),U,7)
SET ECCSC=$PIECE($GET(^SC(ECXCL,0)),U,18)
IF ECSC
Begin DoDot:2
+21 SET ECXP1=$PIECE($GET(^DIC(40.7,ECSC,0)),U,2)
if ECCSC]""
SET ECXP2=$PIECE($GET(^DIC(40.7,ECCSC,0)),U,2)
+22 SET ECXP1=$$RJ^XLFSTR(ECXP1,3,0)
SET ECXP2=$$RJ^XLFSTR(ECXP2,3,0)
End DoDot:2
+23 SET ECXDSSI=ECXP1_ECXP2
+24 IF ECXLOGIC>2003
Begin DoDot:2
+25 IF "^18^23^24^41^65^94^108^"[("^"_ECXTS_"^")
SET ECXDSSI=$$TSMAP^ECXUTL4(ECXTS)
End DoDot:2
End DoDot:1
+26 ;174
SET (ECINV,ECXDEA)=$PIECE(ECXPHA,U,4)
SET ECST=ECXCNT*ECST_" "_$PIECE(ECST,U,2)
+27 ;New way to calculate cost dea spl hndlg **136 upd precedence **144
+28 IF ECXLOGIC>2012
SET ECINV=$SELECT((+ECINV>0)&(+ECINV<6):+ECINV,ECINV["I":"I",1:"")
Begin DoDot:1
+29 ; Update cost calculation use exist cost x quant x count
+30 ;143
SET ECXCOST=+ECST*ECXCOST
End DoDot:1
+31 ; old method of dea spl hndlg **136
+32 IF ECXLOGIC<2013
SET ECINV=$SELECT(ECINV["I":"I",1:"")
+33 SET ECNDC=$PIECE(ECXPHA,U,3)
SET ECNFC=$$RJ^XLFSTR($PIECE(ECNDC,"-"),6,0)_$$RJ^XLFSTR($PIECE(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($PIECE(ECNDC,"-",3),2,0)
SET ECNFC=$TRANSLATE(ECNFC,"*",0)
+34 ;170,174 Reset NDC to null if it's missing from file 50
IF ECNDC["LCL"!(ECNDC["LCD")
SET ECNDC=""
+35 SET P1=$PIECE(ECXPHA,U,5)
SET P3=$PIECE(ECXPHA,U,6)
+36 SET X="PSNAPIS"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC
+37 IF $LENGTH(ECNFC)=12
SET ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC
+38 ;- Ordering provider ("2"_provider)
+39 SET ECXORDPR=$SELECT(+$PIECE(EC,U,10):"2"_$PIECE(EC,U,10),1:"")
+40 NEW ECXUSRTN
+41 SET ECXUSRTN=$$NPI^XUSNPI("Individual_ID",$PIECE(EC,U,10),$PIECE(EC,U,16))
+42 if +ECXUSRTN'>0
SET ECXUSRTN=""
SET ECXOPNPI=$PIECE(ECXUSRTN,U)
+43 ;- Ordering date
SET ECXORDDT=$PIECE(EC,U,16)
+44 ;- Requesting physician (null for FY2002)
+45 SET ECXRPHY=""
+46 ;- Department and National Prod Division
+47 ;dss department use postponed $$IVP^ECXDEPT(ECXDIV)
SET ECXDSSD=""
+48 NEW ECXPDIV
SET ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV)
+49 ;tjl 166 For outpatients, set Station Number to Prod Div Code
IF ECXA="O"
SET ECXSTANO=ECXPDIV
+50 ;- Observation patient indicator (yes/no)
+51 SET ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXDSSI)
+52 ; - Ordering Date, Ordering Stop Code
+53 ;170
SET ECXORDST=""
if ECXA="O"
SET ECXORDST=$$DOIVPO^ECXUTL5(DFN,ON)
SET ECORDST=ECXORDST
+54 ;181 - No/Inactive Stop Code, default to PHA. Save information to send mail later
IF $PIECE(ECXORDST,U,2)'=""
Begin DoDot:1
+55 DO SETTMP(ECXORDST)
+56 SET (ECORDST,ECXORDST)="PHA"
End DoDot:1
+57 ;- If no encounter number don't file record
+58 SET ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADM,ECD,ECXTS,ECXOBS,ECHEAD,ECORDST,)
+59 ;144 BCMA fields are place holder now
SET (ECXBCDD,ECXBCDG,ECXBCUA,ECXBCIF)=""
+60 ;get ordering provider person class
+61 SET ECXOPPC=$$PRVCLASS^ECXUTL($EXTRACT(ECXORDPR,2,999),ECXORDDT)
+62 ;set national patient record flag if exist
+63 SET ECXDFN=DFN
DO NPRF^ECXUTL5
KILL ECXDFN
+64 ;170
IF $GET(ECXASIH)
SET ECXA="A"
+65 ;187,190
if ECXDUNIT']""
SET ECXDUNIT=$PIECE(ECXPHA,U,8)
SET ECXPPDU=$PIECE(ECXPHA,U,7)
+66 if ECXENC'=""
DO FILE^ECXPIVD2
KILL P1,P3
+67 QUIT
PAT(ECXDFN,ECXDATE,ECXERR) ;get patient demographics, primary care, and inpatient data
+1 NEW X
+2 ;N ECXNMPI,ECXCERN,ECXSIGI ;184 - Fields added
+3 ;184
SET ECXCERN=""
+4 SET (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP,ECXOEF,ECXOEFDT)=""
+5 ;get patient data if saved
+6 IF $DATA(^TMP($JOB,"ECXP",ECXDFN))
Begin DoDot:1
+7 ;184 Added ECXNMPI
SET PT=^TMP($JOB,"ECXP",ECXDFN)
SET ECXPNM=$PIECE(PT,U)
SET ECXSSN=$PIECE(PT,U,2)
SET (ECXNMPI,ECXMPI)=$PIECE(PT,U,3)
+8 SET ECXDOB=$PIECE(PT,U,4)
SET ECXELIG=$PIECE(PT,U,5)
SET ECXSEX=$PIECE(PT,U,6)
SET ECXSTATE=$PIECE(PT,U,7)
SET ECXCNTY=$PIECE(PT,U,8)
SET ECXZIP=$PIECE(PT,U,9)
+9 SET ECXVET=$PIECE(PT,U,10)
SET ECXPOS=$PIECE(PT,U,11)
SET ECXPST=$PIECE(PT,U,12)
SET ECXPLOC=$PIECE(PT,U,13)
SET ECXRST=$PIECE(PT,U,14)
SET ECXAST=$PIECE(PT,U,15)
+10 SET ECXAOL=$PIECE(PT,U,16)
SET ECXPHI=$PIECE(PT,U,17)
SET ECXMST=$PIECE(PT,U,18)
SET ECXENRL=$PIECE(PT,U,19)
SET ECXCNHU=$PIECE(PT,U,20)
SET ECXCAT=$PIECE(PT,U,21)
+11 SET ECXSTAT=$PIECE(PT,U,22)
SET ECXPRIOR=$PIECE(PT,U,23)
SET ECXHNCI=$PIECE(PT,U,24)
SET ECXETH=$PIECE(PT,U,25)
SET ECXRC1=$PIECE(PT,U,26)
SET ECXMTST=$PIECE(PT,U,27)
+12 SET PT1=$GET(^TMP($JOB,"ECXP",ECXDFN,1))
SET ECXERI=$PIECE(PT1,U)
SET ECXEST=$PIECE(PT1,U,2)
SET ECXOEF=$PIECE(PT1,U,3)
SET ECXOEFDT=$PIECE(PT1,U,4)
SET ECXCNTRY=$PIECE(PT1,U,5)
+13 SET ECXSHADI=$PIECE(PT1,U,6)
SET ECXPATCAT=$PIECE(PT1,U,7)
+14 ;144
SET ECXCLST=$PIECE(PT1,U,8)
SET ECXESC=$PIECE(PT1,U,9)
SET ECXECL=$PIECE(PT1,U,10)
+15 ;184 Self Identified Gender
SET ECXSIGI=$PIECE(PT1,U,13)
+16 IF $$ENROLLM^ECXUTL2(ECXDFN)
End DoDot:1
+17 ;set patient data
+18 IF '$DATA(^TMP($JOB,"ECXP",ECXDFN))
Begin DoDot:1
+19 KILL ECXPAT
SET OK=$$PAT^ECXUTL3(ECXDFN,$PIECE(ECXDATE,"."),"1;2;3;5",.ECXPAT)
+20 IF 'OK
KILL ECXPAT
SET ECXERR=1
QUIT
+21 ;184 - Added ECXNMPI
SET ECXPNM=ECXPAT("NAME")
SET ECXSSN=ECXPAT("SSN")
SET (ECXNMPI,ECXMPI)=ECXPAT("MPI")
SET ECXDOB=ECXPAT("DOB")
SET ECXELIG=ECXPAT("ELIG")
SET ECXSEX=ECXPAT("SEX")
+22 SET ECXSTATE=ECXPAT("STATE")
SET ECXCNTY=ECXPAT("COUNTY")
SET ECXZIP=ECXPAT("ZIP")
SET ECXVET=ECXPAT("VET")
SET ECXCNTRY=ECXPAT("COUNTRY")
+23 SET ECXPOS=ECXPAT("POS")
SET ECXPST=ECXPAT("POW STAT")
SET ECXPLOC=ECXPAT("POW LOC")
SET ECXRST=ECXPAT("IR STAT")
+24 SET ECXAST=ECXPAT("AO STAT")
SET ECXAOL=ECXPAT("AOL")
SET ECXPHI=ECXPAT("PHI")
SET ECXMST=ECXPAT("MST STAT")
+25 ;144
SET ECXCLST=ECXPAT("CL STAT")
SET ECXESC=""
SET ECXECL=""
+26 SET ECXENRL=ECXPAT("ENROLL LOC")
SET ECXMTST=ECXPAT("MEANS")
SET ECXEST=ECXPAT("EC STAT")
+27 ;149 COMBAT SVC LOC
SET ECXSVCI=ECXPAT("COMBSVCI")
SET ECXSVCL=ECXPAT("COMBSVCL")
+28 ;184 Self Idenfied Gender
SET ECXSIGI=ECXPAT("SIGI")
+29 ;get CNHU status
SET ECXCNHU=$$CNHSTAT^ECXUTL4(ECXDFN)
+30 ;get enrollment data (category, status and priority)
+31 IF $$ENROLLM^ECXUTL2(ECXDFN)
+32 ;Head and Neck Cancer Indicator
SET ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
+33 ;PROJ 112/SHAD Indicator
SET ECXSHADI=$$SHAD^ECXUTL4(ECXDFN)
+34 ; PATCH 127, ADD PATCAT CODE
SET ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
+35 ; - Race and Ethnicity
+36 SET ECXETH=ECXPAT("ETHNIC")
SET ECXRC1=ECXPAT("RACE1")
+37 ;emergency response indicator (FEMA)
SET ECXERI=ECXPAT("ERI")
+38 SET ECXOEF=ECXPAT("ECXOEF")
+39 SET ECXOEFDT=ECXPAT("ECXOEFDT")
+40 ;save for later
+41 SET ^TMP($JOB,"ECXP",ECXDFN)=ECXPNM_U_ECXSSN_U_ECXMPI_U_ECXDOB_U_ECXELIG_U_ECXSEX_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST
+42 SET ^TMP($JOB,"ECXP",ECXDFN)=^TMP($JOB,"ECXP",ECXDFN)_U_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXENRL_U_ECXCNHU_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXHNCI_U_ECXETH_U_ECXRC1_U_ECXMTST
+43 ;149
SET ^TMP($JOB,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST_U_ECXOEF_U_ECXOEFDT_U_ECXCNTRY_U_ECXSHADI_U_ECXPATCAT_U_ECXCLST_U_ECXESC_U_ECXECL_U_ECXSVCI_U_ECXSVCL
+44 ;184
SET ^TMP($JOB,"ECXP",ECXDFN,1)=^TMP($JOB,"ECXP",ECXDFN,1)_U_ECXSIGI
End DoDot:1
if 'OK
QUIT
+45 ;get primary care data
+46 SET X=$$PRIMARY^ECXUTL2(ECXDFN,$PIECE(ECXDATE,"."))
+47 SET ECPTTM=$PIECE(X,U,1)
SET ECPTPR=$PIECE(X,U,2)
SET ECCLAS=$PIECE(X,U,3)
SET ECPTNPI=$PIECE(X,U,4)
SET ECASPR=$PIECE(X,U,5)
SET ECCLAS2=$PIECE(X,U,6)
SET ECASNPI=$PIECE(X,U,7)
+48 ;get inpatient data
+49 SET (ECXA,ECXMN,ECXADM,ECXTS,ECXW,ECXDIV)=""
SET X=$$INP^ECXUTL2(ECXDFN,ECXDATE)
+50 ;170
SET ECXA=$PIECE(X,U)
SET ECXMN=$PIECE(X,U,2)
SET ECXTS=$PIECE(X,U,3)
SET ECXADM=$PIECE(X,U,4)
SET W=$PIECE(X,U,9)
SET ECXDOM=$PIECE(X,U,10)
SET ECXW=$PIECE(W,";")
SET ECXDIV=$PIECE(W,";",2)
SET ECXASIH=$PIECE(X,U,14)
+51 ;tjl 166 For inpatients, get Station Number based on Ward
IF ECXA="I"
SET ECXSTANO=$$GETDIV^ECXDEPT(ECXDIV)
+52 QUIT
SETUP ;Set required input for ECXTRAC
+1 SET ECHEAD="IVP"
+2 DO ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+3 ;variables ecver and ecrtn will be reset in routine ecxtrac if appropriate
+4 SET ECVER=7
+5 QUIT
QUE ; entry point for the background requeuing handled by ECXTAUTO
+1 DO SETUP
DO QUE^ECXTAUTO
DO ^ECXKILL
QUIT
+2 ;
SETTMP(STR) ;181 - Set global TMP for Mail Message
+1 NEW CLIN,SCODE,DIC,ECXDIC,ECXDICA,ECXNOSC,ECXINVSC,DIQ,DR,DA
+2 IF $PIECE(STR,U,2)="MISSING STOP CODE"
Begin DoDot:1
+3 SET CLIN=$PIECE(STR,U)
+4 IF $DATA(^TMP($JOB,"ECXIVPM","NOSC",CLIN))
QUIT
+5 IF '$DATA(^TMP($JOB,"ECXIVPM","ECXNOSC"))
SET ^TMP($JOB,"ECXIVPM","ECXNOSC")=0
+6 SET ECXNOSC=^TMP($JOB,"ECXIVPM","ECXNOSC")+1
+7 SET DIC="^SC("
SET DIQ="IE"
SET DIQ="ECXDIC"
SET DR=".01"
SET DA=CLIN
DO EN^DIQ1
+8 SET ^TMP($JOB,"ECXIVPM","ECXNOSC",ECXNOSC,0)=$JUSTIFY(CLIN,8)_" "_$$LJ^XLFSTR(ECXDIC(44,CLIN,.01),32)
+9 SET ^TMP($JOB,"ECXIVPM","ECXNOSC")=ECXNOSC
+10 SET ^TMP($JOB,"ECXIVPM","NOSC",CLIN)=""
End DoDot:1
QUIT
+11 IF $PIECE(STR,U,2)="INVALID STOP CODE"
Begin DoDot:1
+12 SET CLIN=$PIECE(STR,U)
SET SCODE=$PIECE(STR,U,3)
+13 IF $DATA(^TMP($JOB,"ECXIVPM","INVSC",CLIN))
QUIT
+14 IF '$DATA(^TMP($JOB,"ECXIVPM","ECXINVSC"))
SET ^TMP($JOB,"ECXIVPM","ECXINVSC")=0
+15 SET ECXINVSC=^TMP($JOB,"ECXIVPM","ECXINVSC")+1
+16 SET DIC="^SC("
SET DIQ="IE"
SET DIQ="ECXDIC"
SET DR=".01"
SET DA=CLIN
DO EN^DIQ1
+17 SET DIC="^DIC(40.7,"
SET DIQ(0)="E"
SET DIQ="ECXDICA"
SET DR=".01;1;2"
SET DA=SCODE
DO EN^DIQ1
+18 SET ^TMP($JOB,"ECXIVPM","ECXINVSC",ECXINVSC,0)=$JUSTIFY(CLIN,8)_"/"_$$LJ^XLFSTR(ECXDIC(44,CLIN,.01),25)_" "_$JUSTIFY(ECXDICA(40.7,SCODE,1,"E"),8)_"/"_$$LJ^XLFSTR(ECXDICA(40.7,SCODE,.01,"E"),25)
+19 SET ^TMP($JOB,"ECXIVPM","ECXINVSC")=ECXINVSC
+20 SET ^TMP($JOB,"ECXIVPM","INVSC",CLIN)=""
End DoDot:1
+21 QUIT
