ECXOPRX ;ALB/JAP,BIR/DMA,CML,PTD-Prescription Extract for DSS ;7/18/19 09:40
;;3.0;DSS EXTRACTS;**10,11,8,13,24,30,33,38,39,46,49,71,81,84,92,105,112,120,127,136,144,149,154,166,170,174,178,184,187**;Dec 22, 1997;Build 163
;
; Reference to $$DSS^PSNAPIS in ICR #2531
; Reference to DIQ^PSODI in ICR #4858
; Reference to $$NPI^XUSNPI in ICR #4532
;
BEG ;entry point from option
D SETUP I ECFILE="" Q
D ^ECXTRAC,^ECXKILL
Q
;
START ;entry when queued
N X,DA,DIC,DIQ,DR,ECXNPRFI,ECRXPTST,ECNONVAP,ECRXNUM,ECXSCRX,ECXESC,ECXCLST,ECXECL,ECXCHOCE,ECXRXREM ;144,154,174
N ECXOCLIN,ECXSTANO,ECXDEA ;166,174
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
;before V6
S ECPROF=6,ECD=$O(^PSRX("AL",0)) I ECD,ECD<ECSD1 G V6
S ECED=ECED+.3,ECREF=1,ECD=ECSD1
F S ECD=$O(^PSRX("AD",ECD)),ECRX=0 Q:'ECD Q:ECD>ECED Q:QFLG F S ECRX=$O(^PSRX("AD",ECD,ECRX)),ECRFL="" Q:'ECRX F S ECRFL=$O(^PSRX("AD",ECD,ECRX,ECRFL)) Q:ECRFL="" D STUFF Q:QFLG
Q
;
V6 ;version 6 or better
K ^TMP($J,"ECXP")
S ECPROF=2,ECED=ECED+.3,ECREF=1,ECD=ECSD1
F S ECD=$O(^PSRX("AL",ECD)),ECRX=0 Q:'ECD Q:ECD>ECED Q:QFLG F S ECRX=$O(^PSRX("AL",ECD,ECRX)),ECRFL="" Q:'ECRX F S ECRFL=$O(^PSRX("AL",ECD,ECRX,ECRFL)) Q:ECRFL="" D STUFF Q:QFLG
Q:QFLG
S ECREF="P",ECD=ECSD1
F S ECD=$O(^PSRX("AM",ECD)),ECRX=0 Q:'ECD Q:ECD>ECED Q:QFLG F S ECRX=$O(^PSRX("AM",ECD,ECRX)),ECRFL="" Q:'ECRX F S ECRFL=$O(^PSRX("AM",ECD,ECRX,ECRFL)) Q:ECRFL="" D STUFF Q:QFLG
K ^TMP($J,"ECXP")
Q
;
STUFF ;get data
N ECXPHA,DR,DIC,DA,DIQ,ECXASIH,ECXDIQ ;154,170
N ECXNMPI,ECXCERN,ECXSIGI ;184 - Added new new fields
N ECXDUNIT,ECXPPDU ;187 - Added Dispense Unit and Price Per Dispense Unit
S ECDATA=$G(^PSRX(ECRX,0)),ECXPHA="" Q:'ECDATA
I ECRFL S ECDATA1=$G(^PSRX(ECRX,ECREF,ECRFL,0)) I ECDATA1="" Q
;ecref set to 1 in extract+5 and v6+1 and to "P" in v6+2
;refill nodes and partial nodes are identical in layout. Fills
;(ie ecrfl=0)& refills (ie ecrfl>0) from "AL" xref, partials from "AM"
S (ECXDSSD,ECXPROVN,ECXCVE,ECXCVEDT,ECXCVENC,ECRXPTST,ECRXNUM)="",ECXERR=0,ECXDATE=ECD,ECXDFN=$P(ECDATA,U,2),ECDRG=+$P(ECDATA,U,6)
;- Get rx patient status & rx number
S ECRXPTST=$$RXPTST^ECXUTL5($P(ECDATA,U,3)),ECRXNUM=$P(ECDATA,U,1)
;- Get provider (either 2_provider or 6_provider depending on version)
S ECXPROV=$S($P(ECDATA,U,4)'="":ECPROF_$P(ECDATA,U,4),1:""),ECXPROVP=$$PRVCLASS^ECXUTL($P(ECDATA,U,4),ECXDATE)
S ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$P(ECDATA,U,4),ECXDATE)
S:+ECPRVNPI'>0 ECPRVNPI="" S ECPRVNPI=$P(ECPRVNPI,U)
;get classification data
;154 Added section to use call to PSODI for obtaining data
F DR=116:1:121,122.01,128 D
.S DIC=52
.S DA=ECRX
.S DIQ="ECXDIQ"
.D DIQ^PSODI(DIC,DIC,DR,DA,DIQ)
.S @$S(DR=116:"ECXESC",DR=117:"ECXMIL",DR=118:"ECXAO",DR=119:"ECXIR",DR=120:"ECXECE",DR=121:"ECXHNC",DR=122.01:"ECXSHAD",1:"ECXECL")=$S($G(ECXDIQ(52,DA,DR))="YES":"Y",$G(ECXDIQ(52,DA,DR))="NO":"N",1:"")
.S ECXSCRX=ECXESC
;- Check non-va provider flag and set to 'Y' if exist
S ECNONVAP=$$NONVAP^ECXUTL5($E(ECXPROV,2,99))
; ******* - PATCH 127, ADD PATCAT CODE ********
S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
;get patient specific data
D PAT(ECXDFN,ECXDATE,.ECXERR) Q:ECXERR
I 'ECRFL D
.S ECMW=$P(ECDATA,U,11),ECQTY=+$P(ECDATA,U,7),ECXDIV=$S($D(^PSRX(ECRX,2)):$P(^(2),U,9),1:1)
.S ECPRC=+$P(ECDATA,U,17),ECOPAY=$P($G(^PSRX(ECRX,"IB")),U,2)]""
I ECRFL D
.S ECMW=$P(ECDATA1,U,2),ECQTY=+$P(ECDATA1,U,4),ECXDIV=$S(+$P(ECDATA1,U,9):$P(ECDATA1,U,9),1:1)
.S ECPRC=+$P(ECDATA1,U,11),ECOPAY=$P($G(^PSRX(ECRX,1,ECRFL,"IB")),U)]""
S ECXCOST=$J((ECQTY*ECPRC),1,2),ECDS=$S(ECRFL:$P(ECDATA1,U,10),1:$P(ECDATA,U,8))
;call pharmacy drug file (#50) api
S ECXPHA=$$PHAAPI^ECXUTL5(ECDRG),ECCAT=$P(ECXPHA,U,2),(ECINV,ECXDEA)=$P(ECXPHA,U,4) ;174
; new method of dea spl hndlg **136 updated precedence *144
I ECXLOGIC>2012 S ECINV=$S((+ECINV>0)&(+ECINV<6):+ECINV,ECINV["I":"I",1:"")
; old method of dea spl hndlg **136
I ECXLOGIC<2013 S ECINV=$S(ECINV["I":"I",1:"")
S ECUI=$P(ECXPHA,U,8),ECNDC=$P(ECXPHA,U,3)
S 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),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
I ECMW="M" S ECMW=1 I $D(^PSRX("AR",ECD,ECRX)) S ECMW=2
I ECMW="W" S ECMW=""
S ECXNEW="" I ECRFL=0 S ECXNEW=1
I $E(ECRXNUM,$L(ECRXNUM))?1A S ECXNEW=2 ;178 - RX is a renewal
S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) ;Observation pat indic (YES/NO)
S ECXORDPH="" ;Ordering physician (null for FY2002)
;- Ordering stop code & Ordering date
S ECXOCLIN=+$P(ECDATA,U,5) ;166 tjl - Get Ordering Clinic from piece 5 of prescription record
S ECXORDST=$P($G(^ECX(728.44,ECXOCLIN,0)),U,2)
S ECXORDDT=$$ECXDATE^ECXUTL(+$P(ECDATA,U,13),ECXYM) ;166 tjl - Split for legibility
S ECXSTANO=$$RADDIV^ECXDEPT($P($G(^SC(ECXOCLIN,0)),U,4)) ;166 tjl - Get Patient Division based on Ordering Clinic
S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) ;CNH status (YES/NO)
;- DSS Dept and National Prod Division
;S ECXDSSD=$$PRE^ECXDEPT(ECXDIV,ECMW,ECINST) dss department postponed
N ECXPDIV S ECXPDIV=$$PREDIV^ECXDEPT(ECXDIV)
;- Set national patient record flag if exist
D NPRF^ECXUTL5
;- If no encounter number don't file record
S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,)
I ECXLOGIC>2003 D
.I (ECMW=2)!((ECMW=1)&(ECXLOGIC>2006)),ECXSSN'="" D
.. N TMP
.. I (ECXLOGIC>2008) S TMP=$$JULDT^ECXUTL4(ECD),ECXENC=$E(ECXSSN,1,9)_TMP_"PHA"
.. E S TMP=$$JULDT^ECXUTL4(ECD),ECXENC=$E(ECXSSN,1,9)_TMP_"160"
.. I (ECXLOGIC>2009),(ECXOBS="YES") S ECXOBS=""
.. S ECXA="O"
S ECXRXREM=$$UP^XLFSTR($$GET1^DIQ(52,ECRX_",",12)) ;174 Get remark field
S ECXCHOCE=$S(ECXRXREM["CHOICE"!(ECXRXREM["CCNRX"):"C",1:"") ;154,174 If remarks contain "choice" RX is filled by choice program. 174 add "CCNRX"
I $G(ECXASIH) S ECXA="A" ;170
S ECXPPDU=$P(ECXPHA,U,7),ECXDUNIT=$P(ECXPHA,U,8) ;187
I ECXENC'="" D FILE^ECXOPRX1
Q
;
PAT(ECXDFN,ECXDATE,ECXERR) ;Determine in/outpatient status, movement number, primary care team and provider
N OK,X,PT
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),ECXSSN=$P(PT,U),ECXPNM=$P(PT,U,2),(ECXNMPI,ECXMPI)=$P(PT,U,3),ECXSEX=$P(PT,U,4),ECXDOB=$P(PT,U,5) ;184 - Added ECXNMPI
.S ECXELIG=$P(PT,U,6),ECXVET=$P(PT,U,7),ECXRACE=$P(PT,U,8),ECXPST=$P(PT,U,9),ECXPLOC=$P(PT,U,10),ECXRST=$P(PT,U,11)
.S ECXAST=$P(PT,U,12),ECXMST=$P(PT,U,13),ECXSTATE=$P(PT,U,14),ECXCNTY=$P(PT,U,15),ECXZIP=$P(PT,U,16),ECXENRL=$P(PT,U,17)
.S ECXPHI=$P(PT,U,20),ECXCAT=$P(PT,U,21),ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23)
.S ECXCNHU=$P(PT,U,24),ECXPOS=$P(PT,U,25),ECXAOL=$P(PT,U,26),ECXHNCI=$P(PT,U,27),ECXETH=$P(PT,U,28),ECXRC1=$P(PT,U,29),ECXMTST=$P(PT,U,30)
.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 ECXPATCAT=$P(PT1,U,6),ECXSHAD=$P(PT1,U,7),ECXSHADI=$P(PT1,U,8),ECXVNS=$P(PT1,U,9),ECXCLST=$P(PT1,U,10) ;144 Vietnam and Camp Lejeune status
.S ECXSIGI=$P(PT1,U,11) ;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(ECSD1,"."),"1;2;3;5",.ECXPAT)
.I 'OK S ECXERR=1 Q
.S ECXSSN=ECXPAT("SSN"),ECXPNM=ECXPAT("NAME"),(ECXMPI,ECXNMPI)=ECXPAT("MPI"),ECXSEX=ECXPAT("SEX"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG") ;184 - Added ECXNMPI
.S ECXVET=ECXPAT("VET"),ECXRACE=ECXPAT("RACE"),ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT")
.S ECXAST=ECXPAT("AO STAT"),ECXMST=ECXPAT("MST STAT"),ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP"),ECXENRL=ECXPAT("ENROLL LOC")
.S ECXERI=ECXPAT("ERI"),ECXEST=ECXPAT("EC STAT"),ECXCNTRY=ECXPAT("COUNTRY"),ECXVNS=ECXPAT("VIETNAM"),ECXCLST=ECXPAT("CL STAT") ; 144 VIETNAM STATUS and Camp Lejeune Status
.S ECXSVCI=ECXPAT("COMBSVCI"),ECXSVCL=ECXPAT("COMBSVCL") ;149 COMBAT SVC IND/LOC
.S ECXSIGI=ECXPAT("SIGI") ;184 Self Identified Gender
.;- CNH Stat (placeholder),Purp Heart Ind,Per of Svce,AO Loc,MT Stat
.S ECXCNHU="",ECXPHI=ECXPAT("PHI"),ECXPOS=ECXPAT("POS"),ECXAOL=ECXPAT("AOL"),ECXMTST=ECXPAT("MEANS")
.I $$ENROLLM^ECXUTL2(ECXDFN)
.S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) ;Head and Neck Cancer Indicator
.S ECXSHADI=$$SHAD^ECXUTL4(ECXDFN) ;Proj 112/SHAD Indicator
.S ECXETH=ECXPAT("ETHNIC"),ECXRC1=ECXPAT("RACE1") ;Race and Ethnicity
.; OEF/OIF data
.S ECXOEF=ECXPAT("ECXOEF")
.S ECXOEFDT=ECXPAT("ECXOEFDT")
.S ^TMP($J,"ECXP",ECXDFN)=ECXSSN_U_ECXPNM_U_ECXMPI_U_ECXSEX_U_ECXDOB_U_ECXELIG_U_ECXVET_U_ECXRACE_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST_U_ECXMST_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXENRL_U_U
.S ^TMP($J,"ECXP",ECXDFN)=^TMP($J,"ECXP",ECXDFN)_U_ECXPHI_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXCNHU_U_ECXPOS_U_ECXAOL_U_ECXHNCI_U_ECXETH_U_ECXRC1_U_ECXMTST
.S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST_U_ECXOEF_U_ECXOEFDT_U_ECXCNTRY_U_ECXPATCAT_U_ECXSHAD_U_ECXSHADI_U_ECXVNS_U_ECXCLST ;144 VIETNAM STATUS and Camp Lejeune Status
.S ^TMP($J,"ECXP",ECXDFN,1)=^TMP($J,"ECXP",ECXDFN,1)_U_ECXSIGI ;184
;get inpatient data
S (ECXA,ECXADMDT,ECXDOM,ECXMN,ECXTS)="",X=$$INP^ECXUTL2(ECXDFN,ECXDATE) D
.S ECXA=$P(X,U),ECXMN=$P(X,U,2),ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4),ECXASIH=$P(X,U,14) ;170
;get primary care data
S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,".")),ECPTTM=$P(X,U),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)
Q
;
SETUP ;Set required input for ECXTRAC
S ECHEAD="PRE"
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[HECXOPRX 10168 printed Nov 22, 2024@17:03:24 Page 2
ECXOPRX ;ALB/JAP,BIR/DMA,CML,PTD-Prescription Extract for DSS ;7/18/19 09:40
+1 ;;3.0;DSS EXTRACTS;**10,11,8,13,24,30,33,38,39,46,49,71,81,84,92,105,112,120,127,136,144,149,154,166,170,174,178,184,187**;Dec 22, 1997;Build 163
+2 ;
+3 ; Reference to $$DSS^PSNAPIS in ICR #2531
+4 ; Reference to DIQ^PSODI in ICR #4858
+5 ; Reference to $$NPI^XUSNPI in ICR #4532
+6 ;
BEG ;entry point from option
+1 DO SETUP
IF ECFILE=""
QUIT
+2 DO ^ECXTRAC
DO ^ECXKILL
+3 QUIT
+4 ;
START ;entry when queued
+1 ;144,154,174
NEW X,DA,DIC,DIQ,DR,ECXNPRFI,ECRXPTST,ECNONVAP,ECRXNUM,ECXSCRX,ECXESC,ECXCLST,ECXECL,ECXCHOCE,ECXRXREM
+2 ;166,174
NEW ECXOCLIN,ECXSTANO,ECXDEA
+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 ;before V6
+8 SET ECPROF=6
SET ECD=$ORDER(^PSRX("AL",0))
IF ECD
IF ECD<ECSD1
GOTO V6
+9 SET ECED=ECED+.3
SET ECREF=1
SET ECD=ECSD1
+10 FOR
SET ECD=$ORDER(^PSRX("AD",ECD))
SET ECRX=0
if 'ECD
QUIT
if ECD>ECED
QUIT
if QFLG
QUIT
FOR
SET ECRX=$ORDER(^PSRX("AD",ECD,ECRX))
SET ECRFL=""
if 'ECRX
QUIT
FOR
SET ECRFL=$ORDER(^PSRX("AD",ECD,ECRX,ECRFL))
if ECRFL=""
QUIT
DO STUFF
if QFLG
QUIT
+11 QUIT
+12 ;
V6 ;version 6 or better
+1 KILL ^TMP($JOB,"ECXP")
+2 SET ECPROF=2
SET ECED=ECED+.3
SET ECREF=1
SET ECD=ECSD1
+3 FOR
SET ECD=$ORDER(^PSRX("AL",ECD))
SET ECRX=0
if 'ECD
QUIT
if ECD>ECED
QUIT
if QFLG
QUIT
FOR
SET ECRX=$ORDER(^PSRX("AL",ECD,ECRX))
SET ECRFL=""
if 'ECRX
QUIT
FOR
SET ECRFL=$ORDER(^PSRX("AL",ECD,ECRX,ECRFL))
if ECRFL=""
QUIT
DO STUFF
if QFLG
QUIT
+4 if QFLG
QUIT
+5 SET ECREF="P"
SET ECD=ECSD1
+6 FOR
SET ECD=$ORDER(^PSRX("AM",ECD))
SET ECRX=0
if 'ECD
QUIT
if ECD>ECED
QUIT
if QFLG
QUIT
FOR
SET ECRX=$ORDER(^PSRX("AM",ECD,ECRX))
SET ECRFL=""
if 'ECRX
QUIT
FOR
SET ECRFL=$ORDER(^PSRX("AM",ECD,ECRX,ECRFL))
if ECRFL=""
QUIT
DO STUFF
if QFLG
QUIT
+7 KILL ^TMP($JOB,"ECXP")
+8 QUIT
+9 ;
STUFF ;get data
+1 ;154,170
NEW ECXPHA,DR,DIC,DA,DIQ,ECXASIH,ECXDIQ
+2 ;184 - Added new new fields
NEW ECXNMPI,ECXCERN,ECXSIGI
+3 ;187 - Added Dispense Unit and Price Per Dispense Unit
NEW ECXDUNIT,ECXPPDU
+4 SET ECDATA=$GET(^PSRX(ECRX,0))
SET ECXPHA=""
if 'ECDATA
QUIT
+5 IF ECRFL
SET ECDATA1=$GET(^PSRX(ECRX,ECREF,ECRFL,0))
IF ECDATA1=""
QUIT
+6 ;ecref set to 1 in extract+5 and v6+1 and to "P" in v6+2
+7 ;refill nodes and partial nodes are identical in layout. Fills
+8 ;(ie ecrfl=0)& refills (ie ecrfl>0) from "AL" xref, partials from "AM"
+9 SET (ECXDSSD,ECXPROVN,ECXCVE,ECXCVEDT,ECXCVENC,ECRXPTST,ECRXNUM)=""
SET ECXERR=0
SET ECXDATE=ECD
SET ECXDFN=$PIECE(ECDATA,U,2)
SET ECDRG=+$PIECE(ECDATA,U,6)
+10 ;- Get rx patient status & rx number
+11 SET ECRXPTST=$$RXPTST^ECXUTL5($PIECE(ECDATA,U,3))
SET ECRXNUM=$PIECE(ECDATA,U,1)
+12 ;- Get provider (either 2_provider or 6_provider depending on version)
+13 SET ECXPROV=$SELECT($PIECE(ECDATA,U,4)'="":ECPROF_$PIECE(ECDATA,U,4),1:"")
SET ECXPROVP=$$PRVCLASS^ECXUTL($PIECE(ECDATA,U,4),ECXDATE)
+14 SET ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$PIECE(ECDATA,U,4),ECXDATE)
+15 if +ECPRVNPI'>0
SET ECPRVNPI=""
SET ECPRVNPI=$PIECE(ECPRVNPI,U)
+16 ;get classification data
+17 ;154 Added section to use call to PSODI for obtaining data
+18 FOR DR=116:1:121,122.01,128
Begin DoDot:1
+19 SET DIC=52
+20 SET DA=ECRX
+21 SET DIQ="ECXDIQ"
+22 DO DIQ^PSODI(DIC,DIC,DR,DA,DIQ)
+23 SET @$SELECT(DR=116:"ECXESC",DR=117:"ECXMIL",DR=118:"ECXAO",DR=119:"ECXIR",DR=120:"ECXECE",DR=121:"ECXHNC",DR=122.01:"ECXSHAD",1:"ECXECL")=$SELECT($GET(ECXDIQ(52,DA,DR))="YES":"Y",$GET(ECXDIQ(52,DA,DR))="NO":"N",1:"")
+24 SET ECXSCRX=ECXESC
End DoDot:1
+25 ;- Check non-va provider flag and set to 'Y' if exist
+26 SET ECNONVAP=$$NONVAP^ECXUTL5($EXTRACT(ECXPROV,2,99))
+27 ; ******* - PATCH 127, ADD PATCAT CODE ********
+28 SET ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
+29 ;get patient specific data
+30 DO PAT(ECXDFN,ECXDATE,.ECXERR)
if ECXERR
QUIT
+31 IF 'ECRFL
Begin DoDot:1
+32 SET ECMW=$PIECE(ECDATA,U,11)
SET ECQTY=+$PIECE(ECDATA,U,7)
SET ECXDIV=$SELECT($DATA(^PSRX(ECRX,2)):$PIECE(^(2),U,9),1:1)
+33 SET ECPRC=+$PIECE(ECDATA,U,17)
SET ECOPAY=$PIECE($GET(^PSRX(ECRX,"IB")),U,2)]""
End DoDot:1
+34 IF ECRFL
Begin DoDot:1
+35 SET ECMW=$PIECE(ECDATA1,U,2)
SET ECQTY=+$PIECE(ECDATA1,U,4)
SET ECXDIV=$SELECT(+$PIECE(ECDATA1,U,9):$PIECE(ECDATA1,U,9),1:1)
+36 SET ECPRC=+$PIECE(ECDATA1,U,11)
SET ECOPAY=$PIECE($GET(^PSRX(ECRX,1,ECRFL,"IB")),U)]""
End DoDot:1
+37 SET ECXCOST=$JUSTIFY((ECQTY*ECPRC),1,2)
SET ECDS=$SELECT(ECRFL:$PIECE(ECDATA1,U,10),1:$PIECE(ECDATA,U,8))
+38 ;call pharmacy drug file (#50) api
+39 ;174
SET ECXPHA=$$PHAAPI^ECXUTL5(ECDRG)
SET ECCAT=$PIECE(ECXPHA,U,2)
SET (ECINV,ECXDEA)=$PIECE(ECXPHA,U,4)
+40 ; new method of dea spl hndlg **136 updated precedence *144
+41 IF ECXLOGIC>2012
SET ECINV=$SELECT((+ECINV>0)&(+ECINV<6):+ECINV,ECINV["I":"I",1:"")
+42 ; old method of dea spl hndlg **136
+43 IF ECXLOGIC<2013
SET ECINV=$SELECT(ECINV["I":"I",1:"")
+44 SET ECUI=$PIECE(ECXPHA,U,8)
SET ECNDC=$PIECE(ECXPHA,U,3)
+45 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)
SET P1=$PIECE(ECXPHA,U,5)
SET P3=$PIECE(ECXPHA,U,6)
+46 SET X="PSNAPIS"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC
+47 IF $LENGTH(ECNFC)=12
SET ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC
+48 IF ECMW="M"
SET ECMW=1
IF $DATA(^PSRX("AR",ECD,ECRX))
SET ECMW=2
+49 IF ECMW="W"
SET ECMW=""
+50 SET ECXNEW=""
IF ECRFL=0
SET ECXNEW=1
+51 ;178 - RX is a renewal
IF $EXTRACT(ECRXNUM,$LENGTH(ECRXNUM))?1A
SET ECXNEW=2
+52 ;Observation pat indic (YES/NO)
SET ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
+53 ;Ordering physician (null for FY2002)
SET ECXORDPH=""
+54 ;- Ordering stop code & Ordering date
+55 ;166 tjl - Get Ordering Clinic from piece 5 of prescription record
SET ECXOCLIN=+$PIECE(ECDATA,U,5)
+56 SET ECXORDST=$PIECE($GET(^ECX(728.44,ECXOCLIN,0)),U,2)
+57 ;166 tjl - Split for legibility
SET ECXORDDT=$$ECXDATE^ECXUTL(+$PIECE(ECDATA,U,13),ECXYM)
+58 ;166 tjl - Get Patient Division based on Ordering Clinic
SET ECXSTANO=$$RADDIV^ECXDEPT($PIECE($GET(^SC(ECXOCLIN,0)),U,4))
+59 ;CNH status (YES/NO)
SET ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN)
+60 ;- DSS Dept and National Prod Division
+61 ;S ECXDSSD=$$PRE^ECXDEPT(ECXDIV,ECMW,ECINST) dss department postponed
+62 NEW ECXPDIV
SET ECXPDIV=$$PREDIV^ECXDEPT(ECXDIV)
+63 ;- Set national patient record flag if exist
+64 DO NPRF^ECXUTL5
+65 ;- If no encounter number don't file record
+66 SET ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,)
+67 IF ECXLOGIC>2003
Begin DoDot:1
+68 IF (ECMW=2)!((ECMW=1)&(ECXLOGIC>2006))
IF ECXSSN'=""
Begin DoDot:2
+69 NEW TMP
+70 IF (ECXLOGIC>2008)
SET TMP=$$JULDT^ECXUTL4(ECD)
SET ECXENC=$EXTRACT(ECXSSN,1,9)_TMP_"PHA"
+71 IF '$TEST
SET TMP=$$JULDT^ECXUTL4(ECD)
SET ECXENC=$EXTRACT(ECXSSN,1,9)_TMP_"160"
+72 IF (ECXLOGIC>2009)
IF (ECXOBS="YES")
SET ECXOBS=""
+73 SET ECXA="O"
End DoDot:2
End DoDot:1
+74 ;174 Get remark field
SET ECXRXREM=$$UP^XLFSTR($$GET1^DIQ(52,ECRX_",",12))
+75 ;154,174 If remarks contain "choice" RX is filled by choice program. 174 add "CCNRX"
SET ECXCHOCE=$SELECT(ECXRXREM["CHOICE"!(ECXRXREM["CCNRX"):"C",1:"")
+76 ;170
IF $GET(ECXASIH)
SET ECXA="A"
+77 ;187
SET ECXPPDU=$PIECE(ECXPHA,U,7)
SET ECXDUNIT=$PIECE(ECXPHA,U,8)
+78 IF ECXENC'=""
DO FILE^ECXOPRX1
+79 QUIT
+80 ;
PAT(ECXDFN,ECXDATE,ECXERR) ;Determine in/outpatient status, movement number, primary care team and provider
+1 NEW OK,X,PT
+2 SET (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP,ECXOEF,ECXOEFDT)=""
+3 ;get patient data if saved
+4 IF $DATA(^TMP($JOB,"ECXP",ECXDFN))
Begin DoDot:1
+5 ;184 - Added ECXNMPI
SET PT=^TMP($JOB,"ECXP",ECXDFN)
SET ECXSSN=$PIECE(PT,U)
SET ECXPNM=$PIECE(PT,U,2)
SET (ECXNMPI,ECXMPI)=$PIECE(PT,U,3)
SET ECXSEX=$PIECE(PT,U,4)
SET ECXDOB=$PIECE(PT,U,5)
+6 SET ECXELIG=$PIECE(PT,U,6)
SET ECXVET=$PIECE(PT,U,7)
SET ECXRACE=$PIECE(PT,U,8)
SET ECXPST=$PIECE(PT,U,9)
SET ECXPLOC=$PIECE(PT,U,10)
SET ECXRST=$PIECE(PT,U,11)
+7 SET ECXAST=$PIECE(PT,U,12)
SET ECXMST=$PIECE(PT,U,13)
SET ECXSTATE=$PIECE(PT,U,14)
SET ECXCNTY=$PIECE(PT,U,15)
SET ECXZIP=$PIECE(PT,U,16)
SET ECXENRL=$PIECE(PT,U,17)
+8 SET ECXPHI=$PIECE(PT,U,20)
SET ECXCAT=$PIECE(PT,U,21)
SET ECXSTAT=$PIECE(PT,U,22)
SET ECXPRIOR=$PIECE(PT,U,23)
+9 SET ECXCNHU=$PIECE(PT,U,24)
SET ECXPOS=$PIECE(PT,U,25)
SET ECXAOL=$PIECE(PT,U,26)
SET ECXHNCI=$PIECE(PT,U,27)
SET ECXETH=$PIECE(PT,U,28)
SET ECXRC1=$PIECE(PT,U,29)
SET ECXMTST=$PIECE(PT,U,30)
+10 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)
+11 ;144 Vietnam and Camp Lejeune status
SET ECXPATCAT=$PIECE(PT1,U,6)
SET ECXSHAD=$PIECE(PT1,U,7)
SET ECXSHADI=$PIECE(PT1,U,8)
SET ECXVNS=$PIECE(PT1,U,9)
SET ECXCLST=$PIECE(PT1,U,10)
+12 ;184 Self Identified Gender
SET ECXSIGI=$PIECE(PT1,U,11)
+13 IF $$ENROLLM^ECXUTL2(ECXDFN)
End DoDot:1
+14 ;set patient data
+15 IF '$DATA(^TMP($JOB,"ECXP",ECXDFN))
Begin DoDot:1
+16 KILL ECXPAT
+17 SET OK=$$PAT^ECXUTL3(ECXDFN,$PIECE(ECSD1,"."),"1;2;3;5",.ECXPAT)
+18 IF 'OK
SET ECXERR=1
QUIT
+19 ;184 - Added ECXNMPI
SET ECXSSN=ECXPAT("SSN")
SET ECXPNM=ECXPAT("NAME")
SET (ECXMPI,ECXNMPI)=ECXPAT("MPI")
SET ECXSEX=ECXPAT("SEX")
SET ECXDOB=ECXPAT("DOB")
SET ECXELIG=ECXPAT("ELIG")
+20 SET ECXVET=ECXPAT("VET")
SET ECXRACE=ECXPAT("RACE")
SET ECXPST=ECXPAT("POW STAT")
SET ECXPLOC=ECXPAT("POW LOC")
SET ECXRST=ECXPAT("IR STAT")
+21 SET ECXAST=ECXPAT("AO STAT")
SET ECXMST=ECXPAT("MST STAT")
SET ECXSTATE=ECXPAT("STATE")
SET ECXCNTY=ECXPAT("COUNTY")
SET ECXZIP=ECXPAT("ZIP")
SET ECXENRL=ECXPAT("ENROLL LOC")
+22 ; 144 VIETNAM STATUS and Camp Lejeune Status
SET ECXERI=ECXPAT("ERI")
SET ECXEST=ECXPAT("EC STAT")
SET ECXCNTRY=ECXPAT("COUNTRY")
SET ECXVNS=ECXPAT("VIETNAM")
SET ECXCLST=ECXPAT("CL STAT")
+23 ;149 COMBAT SVC IND/LOC
SET ECXSVCI=ECXPAT("COMBSVCI")
SET ECXSVCL=ECXPAT("COMBSVCL")
+24 ;184 Self Identified Gender
SET ECXSIGI=ECXPAT("SIGI")
+25 ;- CNH Stat (placeholder),Purp Heart Ind,Per of Svce,AO Loc,MT Stat
+26 SET ECXCNHU=""
SET ECXPHI=ECXPAT("PHI")
SET ECXPOS=ECXPAT("POS")
SET ECXAOL=ECXPAT("AOL")
SET ECXMTST=ECXPAT("MEANS")
+27 IF $$ENROLLM^ECXUTL2(ECXDFN)
+28 ;Head and Neck Cancer Indicator
SET ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
+29 ;Proj 112/SHAD Indicator
SET ECXSHADI=$$SHAD^ECXUTL4(ECXDFN)
+30 ;Race and Ethnicity
SET ECXETH=ECXPAT("ETHNIC")
SET ECXRC1=ECXPAT("RACE1")
+31 ; OEF/OIF data
+32 SET ECXOEF=ECXPAT("ECXOEF")
+33 SET ECXOEFDT=ECXPAT("ECXOEFDT")
+34 SET ^TMP($JOB,"ECXP",ECXDFN)=ECXSSN_U_ECXPNM_U_ECXMPI_U_ECXSEX_U_ECXDOB_U_ECXELIG_U_ECXVET_U_ECXRACE_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST_U_ECXMST_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXENRL_U_U
+35 SET ^TMP($JOB,"ECXP",ECXDFN)=^TMP($JOB,"ECXP",ECXDFN)_U_ECXPHI_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXCNHU_U_ECXPOS_U_ECXAOL_U_ECXHNCI_U_ECXETH_U_ECXRC1_U_ECXMTST
+36 ;144 VIETNAM STATUS and Camp Lejeune Status
SET ^TMP($JOB,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST_U_ECXOEF_U_ECXOEFDT_U_ECXCNTRY_U_ECXPATCAT_U_ECXSHAD_U_ECXSHADI_U_ECXVNS_U_ECXCLST
+37 ;184
SET ^TMP($JOB,"ECXP",ECXDFN,1)=^TMP($JOB,"ECXP",ECXDFN,1)_U_ECXSIGI
End DoDot:1
if 'OK
QUIT
+38 ;get inpatient data
+39 SET (ECXA,ECXADMDT,ECXDOM,ECXMN,ECXTS)=""
SET X=$$INP^ECXUTL2(ECXDFN,ECXDATE)
Begin DoDot:1
+40 ;170
SET ECXA=$PIECE(X,U)
SET ECXMN=$PIECE(X,U,2)
SET ECXTS=$PIECE(X,U,3)
SET ECXDOM=$PIECE(X,U,10)
SET ECXADMDT=$PIECE(X,U,4)
SET ECXASIH=$PIECE(X,U,14)
End DoDot:1
+41 ;get primary care data
+42 SET X=$$PRIMARY^ECXUTL2(ECXDFN,$PIECE(ECXDATE,"."))
SET ECPTTM=$PIECE(X,U)
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)
+43 QUIT
+44 ;
SETUP ;Set required input for ECXTRAC
+1 SET ECHEAD="PRE"
+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
