ECXBCM ;ALB/JAP-Bar Code Medical Administration Extract ;6/13/19 12:36
;;3.0;DSS EXTRACTS;**107,127,132,136,143,144,148,149,154,160,161,166,170,174,181,184,187**;Dec 22, 1997 ;Build 163
;
; Reference to ^TMP($J) and ^TMP("PSJ",$J) in SACC 2.3.2.5.1
; Reference to $$LJ^XLFSTR in ICR #10104
; Reference to $$GET^XUA4A72 in ICR #1625
; Reference to $$NPI^XUSNPI in ICR #4532
;
BEG ;entry point from option
;ECFILE=^ECX(727.833,
D SETUP I ECFILE="" Q
D ^ECXTRAC,^ECXKILL
Q
;
START ; start package specific extract
;
N ECXVAP,RERUN,ECXLDT ;143,154
S RERUN=0,ECXLDT=+$P($G(^ECX(728,1,ECNODE)),U,ECPIECE) I ECXLDT'<ECSD S RERUN=1 ;154 If re-running date range, set RERUN to 1, 160 added ^ to global reference
S ECED=ECED+.3,ECD=ECSD1
S PIEN=0
K ^TMP($J,"ECXBCM") ;181
I $G(ECSD)="" S ECSD=DT
; loop thru and get each new patient, reset the start date to ECSD - begin date from ECXTRAC
F S PIEN=$O(^PSB(53.79,"AADT",PIEN)) Q:('PIEN) S IDAT=ECSD D
.F S IDAT=$O(^PSB(53.79,"AADT",PIEN,IDAT)) Q:'IDAT!(IDAT>ECED) S RIEN="" D
..F S RIEN=$O(^PSB(53.79,"AADT",PIEN,IDAT,RIEN)) Q:'RIEN D
...S ECXNOD=^PSB(53.79,RIEN,0) Q:'ECXNOD S ECXDFN=$P($G(ECXNOD),U) D GET(ECSD,ECED)
I $D(^TMP($J,"ECXBCMM")) D SENDMSG^ECXBCM1 ;181 - Send messages for clinics with no stop code or inactive stop code
I 'RERUN D CLEAN(0,$$FMADD^XLFDT(ECSD,-180)) ;154 If not a rerun, clean out items given global
Q
;
GET(ECSD,ECED) ;get extract data
N ECXESC,ECXECL,ECXCLST,ECXASIH,ECXDEA ;144,170,174
N ECXNMPI,ECXSIGI ;184
N ECXDUNIT,ECXPPDU ;187
S (ACTDT,ECXADT,ECXAMED,ECXASTA,ECXATM,ECXORN,ECXORT,ECXOSC,ECPRO,PLACEHLD,ECXFAC,DRG,ECXESC,ECXECL,ECXCLST)="" ;144
; get needed YYYYDD variable
I $G(ECXYM)="" S ECXYM=$$ECXYM^ECXUTL(DT)
;Get Facility - 166 tjl - Now done after retrieval of Ward information
;I $G(ECXFAC)=""
;.S ECXFAC=+$P(^ECX(728,1,0),U) K ECXDIC S DA=ECXFAC,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
;.D EN^DIQ1 S ECXFAC=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
;
S ECXORN=$$GET1^DIQ(53.79,RIEN,.11)
;get inpatient data
S (ECXA,ECXMN,ECXADM,ECXTS,ECXW)=""
S X=$$INP^ECXUTL2(ECXDFN,IDAT)
S ECXA=$P(X,U),ECXMN=$P(X,U,2),ECXTS=$P(X,U,3),ECXADM=$P(X,U,4),ECXASIH=$P(X,U,14) ;170
S W=$P(X,U,9),ECXDOM=$P(X,U,10),ECXW=$P(W,";")
;166 tjl - Set the Facility to the Station Number (based on the Ward)
S ECXFAC=$$GETDIV^ECXDEPT($P(W,";",2)) ;166 tjl
;166 tjl - if the Facility value is null, get the value from the DSS EXTRACTS file
I $G(ECXFAC)="" D
.S ECXFAC=+$P(^ECX(728,1,0),U) K ECXDIC S DA=ECXFAC,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
.D EN^DIQ1 S ECXFAC=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
; Ordering Stop Code - based on Unit dose or IV
I ECXORN["U" Q:$$CHKUD(ECXDFN,ECSD,ECED) S:ECXA="O" ECXOSC=$$DOUDO^ECXUTL5(ECXDFN,+ECXORN)
I ECXORN["V" Q:$$CHKIV(ECXDFN,ECSD,ECED) S:ECXA="O" ECXOSC=$$DOIVPO^ECXUTL5(ECXDFN,+ECXORN)
I $P(ECXOSC,U,2)'="" D ;181 - NO/Inactive Stop Code, default to PHA. Save information to send mail later
.D SETTMP(ECXOSC)
.S ECXOSC="PHA"
S ECXASTA=$$GET1^DIQ(53.79,RIEN,.09,"I")
I "^G^S^C^I^"'[("^"_ECXASTA_"^") Q ;160 process 'G'iven, 'S'topped,'C'ompleted,'I'nfusing
;get patient demographics
S ECXERR=0 D PAT(ECXDFN,IDAT,.ECXERR) Q:ECXERR
S ECPRO=$$ORDPROV^ECXUTL(ECXDFN,ECXORN,"")
S ACTDT=$$GET1^DIQ(53.79,RIEN,.06,"I")
I ACTDT'=IDAT Q
S ECXADT=$$ECXDATE^ECXUTL(ACTDT,ECXYM)
S ECXATM=$$ECXTIME^ECXUTL(ACTDT)
S ECXORT=$P($G(^TMP("PSJ",$J,1)),U,3) K ^TMP("PSJ",$J)
S ECPROPC=$P($$GET^XUA4A72(ECPRO,$P(ACTDT,".")),U,7)
N ECXUSRTN
S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECPRO,$P(ACTDT,"."))
S:+ECXUSRTN'>0 ECXUSRTN="" S ECPRONPI=$P(ECXUSRTN,U)
S ECXAMED=$$GET1^DIQ(53.79,RIEN,.08,"I")
;Component code data
D CCODE(RIEN)
Q
;
CMPT ; during component/sequence processing, retrieve rest of data record then file it.
S (ECXSCADT,ECXOS,ECXIVID,ECXIR,SCADT,ECXSCADT,ECXSCATM,DRUG,ECVNDC,ECINV,ECVACL,ECXVAP,ECXDEA)="" ;143,174
S (ECXFDK,ECXPPDU,ECXDUNIT)="" ;184,187 Added Dispense Unit
I $G(DRG) D
.S DRUG=$$PHAAPI^ECXUTL5(DRG)
.S ECVNDC=$P(DRUG,U,3)
.S (ECINV,ECXDEA)=$P(DRUG,U,4) ;174
.I ECXLOGIC<2014 D
..S ECINV=$S(ECINV["I":"I",1:"")
.;New way to calculate cost dea spl hndlg **144
.I ECXLOGIC>2013 D
..S ECINV=$S((+ECINV>0)&(+ECINV<6):+ECINV,ECINV["I":"I",1:"")
.S ECVACL=$P(DRUG,U,2)
.S ECXVAP=$P(DRUG,U,6) ;143 set ECXVAP to VA PRODUCT IEN
.I ECXLOGIC>2022 D ;184
..S ECXPPDU=+$P(DRUG,U,7) ;set ECXPPDU to Price Per Dispense Unit
..S ECXFDK=$$RJ^XLFSTR($TR(ECXVAP," ",""),5,0)_$$RJ^XLFSTR($P(ECVNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECVNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECVNDC,"-",3),2,0) ;184 Feeder Key=DRG ien_NDC
.I ECXLOGIC>2023 S ECXDUNIT=$P(DRUG,U,8) ;187 Added Dispense Unit
S SCADT=$$GET1^DIQ(53.79,RIEN,.13,"I")
S ECXSCADT=$$ECXDATE^ECXUTL(SCADT,ECXYM)
S ECXSCATM=$$ECXTIME^ECXUTL(SCADT)
S ECXOS=$$GET1^DIQ(53.79,RIEN,.12,"I")
S ECXIVID=$$GET1^DIQ(53.79,RIEN,.26)
S ECXIR=$$GET1^DIQ(53.79,RIEN,.35)
S ECXDIV=$$RADDIV^ECXDEPT($$GET1^DIQ(53.79,RIEN,.03,"I"))
I ECXDIV="" D S:ECXDIV="" ECXDIV=$G(ECXFAC) ;174, get production division from location if available else set to facility value
.N X,Y,DIC
.S X=$$GET1^DIQ(53.79,RIEN,.02) ;Get patient location from 53.79
.Q:X="" S DIC=44,DIC(0)="" D ^DIC
.Q:Y<0 S ECXDIV=$$GETDIV^ECXDEPT($$GET1^DIQ(44,+Y_",",3.5,"I"))
S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADM,ACTDT,ECXTS,ECXOBS,ECHEAD,,)
I $G(ECXASIH) S ECXA="A" ;170
D:ECXENC'="" FILE^ECXBCM1 ;154 Moved filing task for space considerations
Q
;
PAT(ECXDFN,ECXDATE,ECXERR) ;get patient demographics, primary care, and inpatient data
N X
S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP,ECXOEF,ECXOEFDT)=""
;get patient data
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")
S ECXSSN=ECXPAT("SSN")
S ECXMPI=ECXPAT("MPI") I ECXLOGIC>2022 S ECXNMPI=ECXMPI,ECXMPI="" ;184
S ECXDOB=ECXPAT("DOB")
S ECXELIG=ECXPAT("ELIG")
S ECXSEX=ECXPAT("SEX")
S ECXSTATE=ECXPAT("STATE")
S ECXCNTY=ECXPAT("COUNTY")
S ECXZIP=ECXPAT("ZIP")
S ECXVET=ECXPAT("VET")
S ECXCNTRY=ECXPAT("COUNTRY")
S ECXPOS=ECXPAT("POS")
S ECXPST=ECXPAT("POW STAT")
S ECXPLOC=ECXPAT("POW LOC")
S ECXRST=ECXPAT("IR STAT")
S ECXAST=ECXPAT("AO STAT")
S ECXAOL=ECXPAT("AOL")
S ECXPHI=ECXPAT("PHI")
S ECXMST=ECXPAT("MST STAT")
S ECXENRL=ECXPAT("ENROLL LOC")
S ECXMTST=ECXPAT("MEANS")
S ECXEST=ECXPAT("EC STAT")
S ECXCLST=ECXPAT("CL STAT") ;144 Camp Lejeune status
S ECXSVCI=ECXPAT("COMBSVCI") ;149 COMBAT SVC IND
S ECXSVCL=ECXPAT("COMBSVCL") ;149 COMBAT SVC LOC
S ECXSIGI=ECXPAT("SIGI") ;184 - SELF IDENTIFED GENDER
S ECXCNHU=$$CNHSTAT^ECXUTL4(ECXDFN) S ECXCNHU=$S(ECXCNHU'="":$E(ECXCNHU,1),1:"") ;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
I ECXSHADI="U" S ECXSHADI="" ; If Shad comes back as "U" force to null
S ECXETH=ECXPAT("ETHNIC"),ECXRC1=ECXPAT("RACE1") ; Race and Ethnicity
S ECXERI=ECXPAT("ERI") ; emergency response indicator (FEMA)
S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN) ; PATCAT code / patch 127
S ECXOEF=ECXPAT("ECXOEF")
S ECXOEFDT=ECXPAT("ECXOEFDT")
;
;get primary care data
S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,"."))
S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4)
;get national patient record flag, if it exists
D NPRF^ECXUTL5 ; sets ECXNPRFI
Q
;
CCODE(RIEN) ; get component information
; input - IEN of the BCMA MEDICATION LOG File
;
; output - CCIEN: pointer to a variable pointer field to file #50, #52.6, or #52.7
; CCDORD: .02 field of file #50, #52.6, or #52.7
; CCDGVN: .03 FIELD of file #50, #52.6, or #52.7
; CCUNIT: .04 field of file #50, #52.6, or #52.7
; CCTYPE: derived field, "D", "A", or "S"
;
S (CCIEN,CCDORD,CCDGVN,CCUNIT,CCTYPE)=""
F I=.5,.6,.7 D
.I '$O(^PSB(53.79,RIEN,I,0)) Q
.S J=0 F S J=$O(^PSB(53.79,RIEN,I,J)) Q:'J D
..S DATA=^PSB(53.79,RIEN,I,J,0)
..S (UNITCOST,ECXDRGC,ECXIVSC,ECXIVAC)=0 ;144 NEW COST FIELDS
..S CCIEN=$P(DATA,U),CCDORD=$P(DATA,U,2),CCDGVN=$S($P(DATA,U,3)?1.N1"E"1.N.E:1,+($P(DATA,U,3))>0:+($P(DATA,U,3)),1:1) ;174 Added check for exponential numbers
..S CCUNIT=$S($P(DATA,U,4)?1.N1"E"1.N.E:1,+($P(DATA,U,4))>0:+($P(DATA,U,4)),1:1) ;174 Added check for exponential numbers
..I I=.5 D ;144 New drug Cost Fields added
...S DRG=CCIEN,UNITCOST=$$GET1^DIQ(50,DRG,16,"I")
...;S ECXDRGC=(CCDGVN*CCUNIT)*UNITCOST ;184
...S ECXDRGC=(CCDGVN)*UNITCOST ;184 - Removed the Unit of Admistration from the DRUG cost calculation
..I I=.6 D ;144 New IV Additive Cost Fields added
...S DRG=$$GET1^DIQ(52.6,CCIEN,1,"I"),UNITCOST=$$GET1^DIQ(52.6,CCIEN,7,"I")
...S ECXIVAC=CCDGVN*UNITCOST
..I I=.7 D ;144 New IV Solution Cost Fields added
...S DRG=$$GET1^DIQ(52.7,CCIEN,1,"I"),UNITCOST=$$GET1^DIQ(52.7,CCIEN,7,"I")
...S ECXIVSC=CCDGVN*UNITCOST
..S CCTYPE=$S(I=.5:"D",I=.6:"A",I=.7:"S",1:"")
..S CCIEN=$S(I=.5:CCIEN_";PSDRUG(",I=.6:CCIEN_";PS(52.6,",I=.7:CCIEN_";PS(52.7,",1:"")
..S CCDGVN=$P(DATA,U,3) ;148 Reset component dose given to original value
..S CCUNIT=$P(DATA,U,4) ;148 Reset component unit to original value
..I ECXORN["U" I $$MULTI I '$$FIRST Q ;154,160 If it's a unit dose type order and it's a multi-dose container, only count if it's the 1st administration
..D CMPT
Q
;
CHKIV(ECXDFN,ECSD,ECED) ; Check file 728.113 for matching IV records
; input - ECXDFN DFN of the patient from the BCMA file
; ECSD: Start Date for the extract
; ECED: End Date for the extract
; return - True if the Order is in file 728.113
; False if the Order is Not in file 728.113
;
N IVIEN,ORD,IVORN,ECD,EXTRACT,STDATE,ENDDATE
S (ORD,ECD,STDATE,ENDDATE)=0
S (IVORN,EXTRACT)=""
I '$O(^ECX(728.113,0)) D ; Check to see if data exists in the file, if not, recreate
.S EXTRACT="IV"
.S STDATE=$E($$FMADD^XLFDT(ECSD,-140),1,5)_"01"
.S ENDDATE=ECED
.D START^PSJDSS
S IVORN=$P(ECXORN,"V")
S ECD=$E($$FMADD^XLFDT(ECSD,-140),1,5)_"01"
F S ECD=$O(^ECX(728.113,"A",ECD)) Q:'ECD!(ECD>ECED)!(ORD=IVORN) D
.S ORD=0
.F S ORD=$O(^ECX(728.113,"A",ECD,ECXDFN,ORD)) Q:'ORD!(ORD=IVORN)
I ORD=IVORN Q 1
Q 0 ;Checks show order not in IV 728.113
;
CHKUD(ECXDFN,ECSD,ECED) ; Check file 728.904 for matching Unit dose records
; input - ECXDFN DFN of the patient from the BCMA file
; ECSD: Start Date for the extract
; ECED: End Date for the extract
; return - True if the Order is in file 728.904
; False if the Order is Not in file 728.904
;
N UDIEN,UDORN,ORD,EXTRACT,STDATE,ENDDATE
S (ORD,STDATE,ENDDATE)=0
S (UDORN,EXTRACT)=""
I '$O(^ECX(728.904,0)) D ; Check to see if data exists in the file, if not, recreate
.S EXTRACT="UD"
.S STDATE=$E($$FMADD^XLFDT(ECSD,-140),1,5)_"01"
.S ENDDATE=ECED
.D START^PSJDSS
S UDORN=$P(ECXORN,"U")
F S ORD=$O(^ECX(728.904,"AO",ECXDFN,ORD)) Q:'ORD!(ORD=UDORN)
I ORD=UDORN Q 1
;I $$GET1^DIQ(55.06,UDORN_","_ECXDFN,7,"I")="R" Q 1
Q 0 ;Checks show order not in UD 728.904
;
FIRST() ;154 Section added to determine if this is the first administration of the medication since pharmacist verification
N ALIEN,ADATE,FIRST,VDATE,DONE,IENS,ON
S FIRST=0,VDATE="",DONE=0
S ON=+ECXORN ;get numeric portion of order multiple IEN
S ALIEN=0 F S ALIEN=$O(^PS(55,ECXDFN,$S(ECXORN["U":5,1:"IV"),ON,$S(ECXORN["U":9,1:"A"),ALIEN)) Q:'+ALIEN!(DONE) S IENS=ALIEN_","_ON_","_ECXDFN_"," D
.S ADATE=$$GET1^DIQ($S(ECXORN["U":55.09,1:55.04),IENS,$S(ECXORN["U":".01",1:".05"),"I")
.I ADATE>IDAT S DONE=1 Q ;activity date is after administration date
.I ECXORN["U" I "^VP^VPR^"[("^"_$$GET1^DIQ(55.09,IENS,"2:1")_"^") S VDATE=ADATE
.I ECXORN["V" I $$GET1^DIQ(55.04,IENS,".04")="ORDER VERIFIED BY PHARMACIST" S VDATE=ADATE
I VDATE'="" D
.I '$D(^XTMP("ECXBCM",VDATE,ECXDFN,ECXORN))!($G(^XTMP("ECXBCM",VDATE,ECXDFN,ECXORN))=RIEN) S FIRST=1
.I '$D(^XTMP("ECXBCM",VDATE,ECXDFN,ECXORN)) S ^XTMP("ECXBCM",VDATE,ECXDFN,ECXORN)=RIEN
Q FIRST
;
CLEAN(START,END) ;154 Section added to delete old log entries
N DATE,PAT,ON
S DATE=START F S DATE=$O(^XTMP("ECXBCM",DATE)) Q:'+DATE!(DATE>END) S PAT=0 F S PAT=$O(^XTMP("ECXBCM",DATE,PAT)) Q:'+PAT S ON=0 F S ON=$O(^XTMP("ECXBCM",DATE,PAT,ON)) Q:'+ON K ^XTMP("ECXBCM",DATE,PAT,ON)
S ^XTMP("ECXBCM",0)=$$FMADD^XLFDT($$DT^XLFDT,365)_"^"_$$DT^XLFDT_"^"_"Log of BCMA orders that have already been counted"
Q
;
MULTI() ;154 Section added to determine if this is a multi-dose container
N COMP,TERM,OFF,UNIT,MULTI
S MULTI=1 ;Assume it is a multi-dose container
S UNIT=$$UP^XLFSTR($TR(CCUNIT," 0123456789","")) ;Convert to upper case and remove any numbers or spaces
F COMP="EQUAL","CONTAIN" F OFF=1:1 S TERM=$P($T(@COMP+OFF),";",2) Q:TERM="DONE"!('MULTI) D
.I COMP="EQUAL" I UNIT=TERM S MULTI=0 Q ;Not a multi-dose container
.I COMP="CONTAIN" I UNIT[TERM S MULTI=0 ;Not a multi-dose container
Q MULTI
;
EQUAL ;154,161, list of terms for equality check
;AMP
;AMPULE
;BOTTLE
;CAP
;LOZENGE
;PACKAGE
;PACKET
;PKG
;SUPPOSITORY
;SYRINGE
;TAB
;UNITDOSE
;VIAL
;EACH
;VI
;VL
;SYR
;SYG
;AMPOULE
;CARTRIDGE
;CHEWTAB
;LOZ
;TUBEX
;BAG
;SL FILM
;SL-FILM
;SL_FILM
;PATCH
;PKT
;SUP
;CAN
;DONE
CONTAIN ;154, list of terms for contains check
;AMP,
;CAP,
;CAP/
;SUPP
;TAB,
;SOLUTAB
;SOFTGEL
;DONE
;
SETUP ;Set required input for ECXTRAC.
S ECHEAD="BCM"
D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
Q
;
SETTMP(STR) ;181 - Set 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,"ECXBCMM","NOSC",CLIN)) Q
.I '$D(^TMP($J,"ECXBCMM","ECXNOSC")) S ^TMP($J,"ECXBCMM","ECXNOSC")=0
.S ECXNOSC=^TMP($J,"ECXBCMM","ECXNOSC")+1
.S DIC="^SC(",DIQ="IE",DIQ="ECXDIC",DR=".01",DA=CLIN D EN^DIQ1
.S ^TMP($J,"ECXBCMM","ECXNOSC",ECXNOSC,0)=$J(CLIN,8)_" "_$$LJ^XLFSTR(ECXDIC(44,CLIN,.01),32)
.S ^TMP($J,"ECXBCMM","ECXNOSC")=ECXNOSC
.S ^TMP($J,"ECXBCMM","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,"ECXBCMM","INVSC",CLIN)) Q
.I '$D(^TMP($J,"ECXBCMM","ECXINVSC")) S ^TMP($J,"ECXBCMM","ECXINVSC")=0
.S ECXINVSC=^TMP($J,"ECXBCMM","ECXINVSC")+1
.S CLIN=$P(STR,U),SCODE=$P(STR,U,3)
.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,"ECXBCMM","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,"ECXBCMM","ECXINVSC")=ECXINVSC
.S ^TMP($J,"ECXBCMM","INVSC",CLIN)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXBCM 15288 printed Sep 23, 2025@19:28:20 Page 2
ECXBCM ;ALB/JAP-Bar Code Medical Administration Extract ;6/13/19 12:36
+1 ;;3.0;DSS EXTRACTS;**107,127,132,136,143,144,148,149,154,160,161,166,170,174,181,184,187**;Dec 22, 1997 ;Build 163
+2 ;
+3 ; Reference to ^TMP($J) and ^TMP("PSJ",$J) in SACC 2.3.2.5.1
+4 ; Reference to $$LJ^XLFSTR in ICR #10104
+5 ; Reference to $$GET^XUA4A72 in ICR #1625
+6 ; Reference to $$NPI^XUSNPI in ICR #4532
+7 ;
BEG ;entry point from option
+1 ;ECFILE=^ECX(727.833,
+2 DO SETUP
IF ECFILE=""
QUIT
+3 DO ^ECXTRAC
DO ^ECXKILL
+4 QUIT
+5 ;
START ; start package specific extract
+1 ;
+2 ;143,154
NEW ECXVAP,RERUN,ECXLDT
+3 ;154 If re-running date range, set RERUN to 1, 160 added ^ to global reference
SET RERUN=0
SET ECXLDT=+$PIECE($GET(^ECX(728,1,ECNODE)),U,ECPIECE)
IF ECXLDT'<ECSD
SET RERUN=1
+4 SET ECED=ECED+.3
SET ECD=ECSD1
+5 SET PIEN=0
+6 ;181
KILL ^TMP($JOB,"ECXBCM")
+7 IF $GET(ECSD)=""
SET ECSD=DT
+8 ; loop thru and get each new patient, reset the start date to ECSD - begin date from ECXTRAC
+9 FOR
SET PIEN=$ORDER(^PSB(53.79,"AADT",PIEN))
if ('PIEN)
QUIT
SET IDAT=ECSD
Begin DoDot:1
+10 FOR
SET IDAT=$ORDER(^PSB(53.79,"AADT",PIEN,IDAT))
if 'IDAT!(IDAT>ECED)
QUIT
SET RIEN=""
Begin DoDot:2
+11 FOR
SET RIEN=$ORDER(^PSB(53.79,"AADT",PIEN,IDAT,RIEN))
if 'RIEN
QUIT
Begin DoDot:3
+12 SET ECXNOD=^PSB(53.79,RIEN,0)
if 'ECXNOD
QUIT
SET ECXDFN=$PIECE($GET(ECXNOD),U)
DO GET(ECSD,ECED)
End DoDot:3
End DoDot:2
End DoDot:1
+13 ;181 - Send messages for clinics with no stop code or inactive stop code
IF $DATA(^TMP($JOB,"ECXBCMM"))
DO SENDMSG^ECXBCM1
+14 ;154 If not a rerun, clean out items given global
IF 'RERUN
DO CLEAN(0,$$FMADD^XLFDT(ECSD,-180))
+15 QUIT
+16 ;
GET(ECSD,ECED) ;get extract data
+1 ;144,170,174
NEW ECXESC,ECXECL,ECXCLST,ECXASIH,ECXDEA
+2 ;184
NEW ECXNMPI,ECXSIGI
+3 ;187
NEW ECXDUNIT,ECXPPDU
+4 ;144
SET (ACTDT,ECXADT,ECXAMED,ECXASTA,ECXATM,ECXORN,ECXORT,ECXOSC,ECPRO,PLACEHLD,ECXFAC,DRG,ECXESC,ECXECL,ECXCLST)=""
+5 ; get needed YYYYDD variable
+6 IF $GET(ECXYM)=""
SET ECXYM=$$ECXYM^ECXUTL(DT)
+7 ;Get Facility - 166 tjl - Now done after retrieval of Ward information
+8 ;I $G(ECXFAC)=""
+9 ;.S ECXFAC=+$P(^ECX(728,1,0),U) K ECXDIC S DA=ECXFAC,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
+10 ;.D EN^DIQ1 S ECXFAC=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
+11 ;
+12 SET ECXORN=$$GET1^DIQ(53.79,RIEN,.11)
+13 ;get inpatient data
+14 SET (ECXA,ECXMN,ECXADM,ECXTS,ECXW)=""
+15 SET X=$$INP^ECXUTL2(ECXDFN,IDAT)
+16 ;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 ECXASIH=$PIECE(X,U,14)
+17 SET W=$PIECE(X,U,9)
SET ECXDOM=$PIECE(X,U,10)
SET ECXW=$PIECE(W,";")
+18 ;166 tjl - Set the Facility to the Station Number (based on the Ward)
+19 ;166 tjl
SET ECXFAC=$$GETDIV^ECXDEPT($PIECE(W,";",2))
+20 ;166 tjl - if the Facility value is null, get the value from the DSS EXTRACTS file
+21 IF $GET(ECXFAC)=""
Begin DoDot:1
+22 SET ECXFAC=+$PIECE(^ECX(728,1,0),U)
KILL ECXDIC
SET DA=ECXFAC
SET DIC="^DIC(4,"
SET DIQ(0)="I"
SET DIQ="ECXDIC"
SET DR=".01;99"
+23 DO EN^DIQ1
SET ECXFAC=$GET(ECXDIC(4,DA,99,"I"))
KILL DIC,DIQ,DA,DR,ECXDIC
End DoDot:1
+24 ; Ordering Stop Code - based on Unit dose or IV
+25 IF ECXORN["U"
if $$CHKUD(ECXDFN,ECSD,ECED)
QUIT
if ECXA="O"
SET ECXOSC=$$DOUDO^ECXUTL5(ECXDFN,+ECXORN)
+26 IF ECXORN["V"
if $$CHKIV(ECXDFN,ECSD,ECED)
QUIT
if ECXA="O"
SET ECXOSC=$$DOIVPO^ECXUTL5(ECXDFN,+ECXORN)
+27 ;181 - NO/Inactive Stop Code, default to PHA. Save information to send mail later
IF $PIECE(ECXOSC,U,2)'=""
Begin DoDot:1
+28 DO SETTMP(ECXOSC)
+29 SET ECXOSC="PHA"
End DoDot:1
+30 SET ECXASTA=$$GET1^DIQ(53.79,RIEN,.09,"I")
+31 ;160 process 'G'iven, 'S'topped,'C'ompleted,'I'nfusing
IF "^G^S^C^I^"'[("^"_ECXASTA_"^")
QUIT
+32 ;get patient demographics
+33 SET ECXERR=0
DO PAT(ECXDFN,IDAT,.ECXERR)
if ECXERR
QUIT
+34 SET ECPRO=$$ORDPROV^ECXUTL(ECXDFN,ECXORN,"")
+35 SET ACTDT=$$GET1^DIQ(53.79,RIEN,.06,"I")
+36 IF ACTDT'=IDAT
QUIT
+37 SET ECXADT=$$ECXDATE^ECXUTL(ACTDT,ECXYM)
+38 SET ECXATM=$$ECXTIME^ECXUTL(ACTDT)
+39 SET ECXORT=$PIECE($GET(^TMP("PSJ",$JOB,1)),U,3)
KILL ^TMP("PSJ",$JOB)
+40 SET ECPROPC=$PIECE($$GET^XUA4A72(ECPRO,$PIECE(ACTDT,".")),U,7)
+41 NEW ECXUSRTN
+42 SET ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECPRO,$PIECE(ACTDT,"."))
+43 if +ECXUSRTN'>0
SET ECXUSRTN=""
SET ECPRONPI=$PIECE(ECXUSRTN,U)
+44 SET ECXAMED=$$GET1^DIQ(53.79,RIEN,.08,"I")
+45 ;Component code data
+46 DO CCODE(RIEN)
+47 QUIT
+48 ;
CMPT ; during component/sequence processing, retrieve rest of data record then file it.
+1 ;143,174
SET (ECXSCADT,ECXOS,ECXIVID,ECXIR,SCADT,ECXSCADT,ECXSCATM,DRUG,ECVNDC,ECINV,ECVACL,ECXVAP,ECXDEA)=""
+2 ;184,187 Added Dispense Unit
SET (ECXFDK,ECXPPDU,ECXDUNIT)=""
+3 IF $GET(DRG)
Begin DoDot:1
+4 SET DRUG=$$PHAAPI^ECXUTL5(DRG)
+5 SET ECVNDC=$PIECE(DRUG,U,3)
+6 ;174
SET (ECINV,ECXDEA)=$PIECE(DRUG,U,4)
+7 IF ECXLOGIC<2014
Begin DoDot:2
+8 SET ECINV=$SELECT(ECINV["I":"I",1:"")
End DoDot:2
+9 ;New way to calculate cost dea spl hndlg **144
+10 IF ECXLOGIC>2013
Begin DoDot:2
+11 SET ECINV=$SELECT((+ECINV>0)&(+ECINV<6):+ECINV,ECINV["I":"I",1:"")
End DoDot:2
+12 SET ECVACL=$PIECE(DRUG,U,2)
+13 ;143 set ECXVAP to VA PRODUCT IEN
SET ECXVAP=$PIECE(DRUG,U,6)
+14 ;184
IF ECXLOGIC>2022
Begin DoDot:2
+15 ;set ECXPPDU to Price Per Dispense Unit
SET ECXPPDU=+$PIECE(DRUG,U,7)
+16 ;184 Feeder Key=DRG ien_NDC
SET ECXFDK=$$RJ^XLFSTR($TRANSLATE(ECXVAP," ",""),5,0)_$$RJ^XLFSTR($PIECE(ECVNDC,"-"),6,0)_$$RJ^XLFSTR($PIECE(ECVNDC,"-",2),4,0)_$$RJ^XLFSTR($PIECE(ECVNDC,"-",3),2,0)
End DoDot:2
+17 ;187 Added Dispense Unit
IF ECXLOGIC>2023
SET ECXDUNIT=$PIECE(DRUG,U,8)
End DoDot:1
+18 SET SCADT=$$GET1^DIQ(53.79,RIEN,.13,"I")
+19 SET ECXSCADT=$$ECXDATE^ECXUTL(SCADT,ECXYM)
+20 SET ECXSCATM=$$ECXTIME^ECXUTL(SCADT)
+21 SET ECXOS=$$GET1^DIQ(53.79,RIEN,.12,"I")
+22 SET ECXIVID=$$GET1^DIQ(53.79,RIEN,.26)
+23 SET ECXIR=$$GET1^DIQ(53.79,RIEN,.35)
+24 SET ECXDIV=$$RADDIV^ECXDEPT($$GET1^DIQ(53.79,RIEN,.03,"I"))
+25 ;174, get production division from location if available else set to facility value
IF ECXDIV=""
Begin DoDot:1
+26 NEW X,Y,DIC
+27 ;Get patient location from 53.79
SET X=$$GET1^DIQ(53.79,RIEN,.02)
+28 if X=""
QUIT
SET DIC=44
SET DIC(0)=""
DO ^DIC
+29 if Y<0
QUIT
SET ECXDIV=$$GETDIV^ECXDEPT($$GET1^DIQ(44,+Y_",",3.5,"I"))
End DoDot:1
if ECXDIV=""
SET ECXDIV=$GET(ECXFAC)
+30 SET ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
+31 SET ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADM,ACTDT,ECXTS,ECXOBS,ECHEAD,,)
+32 ;170
IF $GET(ECXASIH)
SET ECXA="A"
+33 ;154 Moved filing task for space considerations
if ECXENC'=""
DO FILE^ECXBCM1
+34 QUIT
+35 ;
PAT(ECXDFN,ECXDATE,ECXERR) ;get patient demographics, primary care, and inpatient data
+1 NEW X
+2 SET (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP,ECXOEF,ECXOEFDT)=""
+3 ;get patient data
+4 KILL ECXPAT
SET OK=$$PAT^ECXUTL3(ECXDFN,$PIECE(ECXDATE,"."),"1;2;3;5",.ECXPAT)
+5 IF 'OK
KILL ECXPAT
SET ECXERR=1
QUIT
+6 SET ECXPNM=ECXPAT("NAME")
+7 SET ECXSSN=ECXPAT("SSN")
+8 ;184
SET ECXMPI=ECXPAT("MPI")
IF ECXLOGIC>2022
SET ECXNMPI=ECXMPI
SET ECXMPI=""
+9 SET ECXDOB=ECXPAT("DOB")
+10 SET ECXELIG=ECXPAT("ELIG")
+11 SET ECXSEX=ECXPAT("SEX")
+12 SET ECXSTATE=ECXPAT("STATE")
+13 SET ECXCNTY=ECXPAT("COUNTY")
+14 SET ECXZIP=ECXPAT("ZIP")
+15 SET ECXVET=ECXPAT("VET")
+16 SET ECXCNTRY=ECXPAT("COUNTRY")
+17 SET ECXPOS=ECXPAT("POS")
+18 SET ECXPST=ECXPAT("POW STAT")
+19 SET ECXPLOC=ECXPAT("POW LOC")
+20 SET ECXRST=ECXPAT("IR STAT")
+21 SET ECXAST=ECXPAT("AO STAT")
+22 SET ECXAOL=ECXPAT("AOL")
+23 SET ECXPHI=ECXPAT("PHI")
+24 SET ECXMST=ECXPAT("MST STAT")
+25 SET ECXENRL=ECXPAT("ENROLL LOC")
+26 SET ECXMTST=ECXPAT("MEANS")
+27 SET ECXEST=ECXPAT("EC STAT")
+28 ;144 Camp Lejeune status
SET ECXCLST=ECXPAT("CL STAT")
+29 ;149 COMBAT SVC IND
SET ECXSVCI=ECXPAT("COMBSVCI")
+30 ;149 COMBAT SVC LOC
SET ECXSVCL=ECXPAT("COMBSVCL")
+31 ;184 - SELF IDENTIFED GENDER
SET ECXSIGI=ECXPAT("SIGI")
+32 ;get CNHU status
SET ECXCNHU=$$CNHSTAT^ECXUTL4(ECXDFN)
SET ECXCNHU=$SELECT(ECXCNHU'="":$EXTRACT(ECXCNHU,1),1:"")
+33 ;get enrollment data (category, status and priority)
+34 IF $$ENROLLM^ECXUTL2(ECXDFN)
+35 ; Head and Neck Cancer Indicator
SET ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
+36 ; PROJ 112/SHAD Indicator
SET ECXSHADI=$$SHAD^ECXUTL4(ECXDFN)
+37 ; If Shad comes back as "U" force to null
IF ECXSHADI="U"
SET ECXSHADI=""
+38 ; Race and Ethnicity
SET ECXETH=ECXPAT("ETHNIC")
SET ECXRC1=ECXPAT("RACE1")
+39 ; emergency response indicator (FEMA)
SET ECXERI=ECXPAT("ERI")
+40 ; PATCAT code / patch 127
SET ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
+41 SET ECXOEF=ECXPAT("ECXOEF")
+42 SET ECXOEFDT=ECXPAT("ECXOEFDT")
+43 ;
+44 ;get primary care data
+45 SET X=$$PRIMARY^ECXUTL2(ECXDFN,$PIECE(ECXDATE,"."))
+46 SET ECPTTM=$PIECE(X,U)
SET ECPTPR=$PIECE(X,U,2)
SET ECCLAS=$PIECE(X,U,3)
SET ECPTNPI=$PIECE(X,U,4)
+47 ;get national patient record flag, if it exists
+48 ; sets ECXNPRFI
DO NPRF^ECXUTL5
+49 QUIT
+50 ;
CCODE(RIEN) ; get component information
+1 ; input - IEN of the BCMA MEDICATION LOG File
+2 ;
+3 ; output - CCIEN: pointer to a variable pointer field to file #50, #52.6, or #52.7
+4 ; CCDORD: .02 field of file #50, #52.6, or #52.7
+5 ; CCDGVN: .03 FIELD of file #50, #52.6, or #52.7
+6 ; CCUNIT: .04 field of file #50, #52.6, or #52.7
+7 ; CCTYPE: derived field, "D", "A", or "S"
+8 ;
+9 SET (CCIEN,CCDORD,CCDGVN,CCUNIT,CCTYPE)=""
+10 FOR I=.5,.6,.7
Begin DoDot:1
+11 IF '$ORDER(^PSB(53.79,RIEN,I,0))
QUIT
+12 SET J=0
FOR
SET J=$ORDER(^PSB(53.79,RIEN,I,J))
if 'J
QUIT
Begin DoDot:2
+13 SET DATA=^PSB(53.79,RIEN,I,J,0)
+14 ;144 NEW COST FIELDS
SET (UNITCOST,ECXDRGC,ECXIVSC,ECXIVAC)=0
+15 ;174 Added check for exponential numbers
SET CCIEN=$PIECE(DATA,U)
SET CCDORD=$PIECE(DATA,U,2)
SET CCDGVN=$SELECT($PIECE(DATA,U,3)?1.N1"E"1.N.E:1,+($PIECE(DATA,U,3))>0:+($PIECE(DATA,U,3)),1:1)
+16 ;174 Added check for exponential numbers
SET CCUNIT=$SELECT($PIECE(DATA,U,4)?1.N1"E"1.N.E:1,+($PIECE(DATA,U,4))>0:+($PIECE(DATA,U,4)),1:1)
+17 ;144 New drug Cost Fields added
IF I=.5
Begin DoDot:3
+18 SET DRG=CCIEN
SET UNITCOST=$$GET1^DIQ(50,DRG,16,"I")
+19 ;S ECXDRGC=(CCDGVN*CCUNIT)*UNITCOST ;184
+20 ;184 - Removed the Unit of Admistration from the DRUG cost calculation
SET ECXDRGC=(CCDGVN)*UNITCOST
End DoDot:3
+21 ;144 New IV Additive Cost Fields added
IF I=.6
Begin DoDot:3
+22 SET DRG=$$GET1^DIQ(52.6,CCIEN,1,"I")
SET UNITCOST=$$GET1^DIQ(52.6,CCIEN,7,"I")
+23 SET ECXIVAC=CCDGVN*UNITCOST
End DoDot:3
+24 ;144 New IV Solution Cost Fields added
IF I=.7
Begin DoDot:3
+25 SET DRG=$$GET1^DIQ(52.7,CCIEN,1,"I")
SET UNITCOST=$$GET1^DIQ(52.7,CCIEN,7,"I")
+26 SET ECXIVSC=CCDGVN*UNITCOST
End DoDot:3
+27 SET CCTYPE=$SELECT(I=.5:"D",I=.6:"A",I=.7:"S",1:"")
+28 SET CCIEN=$SELECT(I=.5:CCIEN_";PSDRUG(",I=.6:CCIEN_";PS(52.6,",I=.7:CCIEN_";PS(52.7,",1:"")
+29 ;148 Reset component dose given to original value
SET CCDGVN=$PIECE(DATA,U,3)
+30 ;148 Reset component unit to original value
SET CCUNIT=$PIECE(DATA,U,4)
+31 ;154,160 If it's a unit dose type order and it's a multi-dose container, only count if it's the 1st administration
IF ECXORN["U"
IF $$MULTI
IF '$$FIRST
QUIT
+32 DO CMPT
End DoDot:2
End DoDot:1
+33 QUIT
+34 ;
CHKIV(ECXDFN,ECSD,ECED) ; Check file 728.113 for matching IV records
+1 ; input - ECXDFN DFN of the patient from the BCMA file
+2 ; ECSD: Start Date for the extract
+3 ; ECED: End Date for the extract
+4 ; return - True if the Order is in file 728.113
+5 ; False if the Order is Not in file 728.113
+6 ;
+7 NEW IVIEN,ORD,IVORN,ECD,EXTRACT,STDATE,ENDDATE
+8 SET (ORD,ECD,STDATE,ENDDATE)=0
+9 SET (IVORN,EXTRACT)=""
+10 ; Check to see if data exists in the file, if not, recreate
IF '$ORDER(^ECX(728.113,0))
Begin DoDot:1
+11 SET EXTRACT="IV"
+12 SET STDATE=$EXTRACT($$FMADD^XLFDT(ECSD,-140),1,5)_"01"
+13 SET ENDDATE=ECED
+14 DO START^PSJDSS
End DoDot:1
+15 SET IVORN=$PIECE(ECXORN,"V")
+16 SET ECD=$EXTRACT($$FMADD^XLFDT(ECSD,-140),1,5)_"01"
+17 FOR
SET ECD=$ORDER(^ECX(728.113,"A",ECD))
if 'ECD!(ECD>ECED)!(ORD=IVORN)
QUIT
Begin DoDot:1
+18 SET ORD=0
+19 FOR
SET ORD=$ORDER(^ECX(728.113,"A",ECD,ECXDFN,ORD))
if 'ORD!(ORD=IVORN)
QUIT
End DoDot:1
+20 IF ORD=IVORN
QUIT 1
+21 ;Checks show order not in IV 728.113
QUIT 0
+22 ;
CHKUD(ECXDFN,ECSD,ECED) ; Check file 728.904 for matching Unit dose records
+1 ; input - ECXDFN DFN of the patient from the BCMA file
+2 ; ECSD: Start Date for the extract
+3 ; ECED: End Date for the extract
+4 ; return - True if the Order is in file 728.904
+5 ; False if the Order is Not in file 728.904
+6 ;
+7 NEW UDIEN,UDORN,ORD,EXTRACT,STDATE,ENDDATE
+8 SET (ORD,STDATE,ENDDATE)=0
+9 SET (UDORN,EXTRACT)=""
+10 ; Check to see if data exists in the file, if not, recreate
IF '$ORDER(^ECX(728.904,0))
Begin DoDot:1
+11 SET EXTRACT="UD"
+12 SET STDATE=$EXTRACT($$FMADD^XLFDT(ECSD,-140),1,5)_"01"
+13 SET ENDDATE=ECED
+14 DO START^PSJDSS
End DoDot:1
+15 SET UDORN=$PIECE(ECXORN,"U")
+16 FOR
SET ORD=$ORDER(^ECX(728.904,"AO",ECXDFN,ORD))
if 'ORD!(ORD=UDORN)
QUIT
+17 IF ORD=UDORN
QUIT 1
+18 ;I $$GET1^DIQ(55.06,UDORN_","_ECXDFN,7,"I")="R" Q 1
+19 ;Checks show order not in UD 728.904
QUIT 0
+20 ;
FIRST() ;154 Section added to determine if this is the first administration of the medication since pharmacist verification
+1 NEW ALIEN,ADATE,FIRST,VDATE,DONE,IENS,ON
+2 SET FIRST=0
SET VDATE=""
SET DONE=0
+3 ;get numeric portion of order multiple IEN
SET ON=+ECXORN
+4 SET ALIEN=0
FOR
SET ALIEN=$ORDER(^PS(55,ECXDFN,$SELECT(ECXORN["U":5,1:"IV"),ON,$SELECT(ECXORN["U":9,1:"A"),ALIEN))
if '+ALIEN!(DONE)
QUIT
SET IENS=ALIEN_","_ON_","_ECXDFN_","
Begin DoDot:1
+5 SET ADATE=$$GET1^DIQ($SELECT(ECXORN["U":55.09,1:55.04),IENS,$SELECT(ECXORN["U":".01",1:".05"),"I")
+6 ;activity date is after administration date
IF ADATE>IDAT
SET DONE=1
QUIT
+7 IF ECXORN["U"
IF "^VP^VPR^"[("^"_$$GET1^DIQ(55.09,IENS,"2:1")_"^")
SET VDATE=ADATE
+8 IF ECXORN["V"
IF $$GET1^DIQ(55.04,IENS,".04")="ORDER VERIFIED BY PHARMACIST"
SET VDATE=ADATE
End DoDot:1
+9 IF VDATE'=""
Begin DoDot:1
+10 IF '$DATA(^XTMP("ECXBCM",VDATE,ECXDFN,ECXORN))!($GET(^XTMP("ECXBCM",VDATE,ECXDFN,ECXORN))=RIEN)
SET FIRST=1
+11 IF '$DATA(^XTMP("ECXBCM",VDATE,ECXDFN,ECXORN))
SET ^XTMP("ECXBCM",VDATE,ECXDFN,ECXORN)=RIEN
End DoDot:1
+12 QUIT FIRST
+13 ;
CLEAN(START,END) ;154 Section added to delete old log entries
+1 NEW DATE,PAT,ON
+2 SET DATE=START
FOR
SET DATE=$ORDER(^XTMP("ECXBCM",DATE))
if '+DATE!(DATE>END)
QUIT
SET PAT=0
FOR
SET PAT=$ORDER(^XTMP("ECXBCM",DATE,PAT))
if '+PAT
QUIT
SET ON=0
FOR
SET ON=$ORDER(^XTMP("ECXBCM",DATE,PAT,ON))
if '+ON
QUIT
KILL ^XTMP("ECXBCM",DATE,PAT,ON)
+3 SET ^XTMP("ECXBCM",0)=$$FMADD^XLFDT($$DT^XLFDT,365)_"^"_$$DT^XLFDT_"^"_"Log of BCMA orders that have already been counted"
+4 QUIT
+5 ;
MULTI() ;154 Section added to determine if this is a multi-dose container
+1 NEW COMP,TERM,OFF,UNIT,MULTI
+2 ;Assume it is a multi-dose container
SET MULTI=1
+3 ;Convert to upper case and remove any numbers or spaces
SET UNIT=$$UP^XLFSTR($TRANSLATE(CCUNIT," 0123456789",""))
+4 FOR COMP="EQUAL","CONTAIN"
FOR OFF=1:1
SET TERM=$PIECE($TEXT(@COMP+OFF),";",2)
if TERM="DONE"!('MULTI)
QUIT
Begin DoDot:1
+5 ;Not a multi-dose container
IF COMP="EQUAL"
IF UNIT=TERM
SET MULTI=0
QUIT
+6 ;Not a multi-dose container
IF COMP="CONTAIN"
IF UNIT[TERM
SET MULTI=0
End DoDot:1
+7 QUIT MULTI
+8 ;
EQUAL ;154,161, list of terms for equality check
+1 ;AMP
+2 ;AMPULE
+3 ;BOTTLE
+4 ;CAP
+5 ;LOZENGE
+6 ;PACKAGE
+7 ;PACKET
+8 ;PKG
+9 ;SUPPOSITORY
+10 ;SYRINGE
+11 ;TAB
+12 ;UNITDOSE
+13 ;VIAL
+14 ;EACH
+15 ;VI
+16 ;VL
+17 ;SYR
+18 ;SYG
+19 ;AMPOULE
+20 ;CARTRIDGE
+21 ;CHEWTAB
+22 ;LOZ
+23 ;TUBEX
+24 ;BAG
+25 ;SL FILM
+26 ;SL-FILM
+27 ;SL_FILM
+28 ;PATCH
+29 ;PKT
+30 ;SUP
+31 ;CAN
+32 ;DONE
CONTAIN ;154, list of terms for contains check
+1 ;AMP,
+2 ;CAP,
+3 ;CAP/
+4 ;SUPP
+5 ;TAB,
+6 ;SOLUTAB
+7 ;SOFTGEL
+8 ;DONE
+9 ;
SETUP ;Set required input for ECXTRAC.
+1 SET ECHEAD="BCM"
+2 DO ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+3 QUIT
+4 ;
SETTMP(STR) ;181 - Set 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,"ECXBCMM","NOSC",CLIN))
QUIT
+5 IF '$DATA(^TMP($JOB,"ECXBCMM","ECXNOSC"))
SET ^TMP($JOB,"ECXBCMM","ECXNOSC")=0
+6 SET ECXNOSC=^TMP($JOB,"ECXBCMM","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,"ECXBCMM","ECXNOSC",ECXNOSC,0)=$JUSTIFY(CLIN,8)_" "_$$LJ^XLFSTR(ECXDIC(44,CLIN,.01),32)
+9 SET ^TMP($JOB,"ECXBCMM","ECXNOSC")=ECXNOSC
+10 SET ^TMP($JOB,"ECXBCMM","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,"ECXBCMM","INVSC",CLIN))
QUIT
+14 IF '$DATA(^TMP($JOB,"ECXBCMM","ECXINVSC"))
SET ^TMP($JOB,"ECXBCMM","ECXINVSC")=0
+15 SET ECXINVSC=^TMP($JOB,"ECXBCMM","ECXINVSC")+1
+16 SET CLIN=$PIECE(STR,U)
SET SCODE=$PIECE(STR,U,3)
+17 SET DIC="^SC("
SET DIQ="IE"
SET DIQ="ECXDIC"
SET DR=".01"
SET DA=CLIN
DO EN^DIQ1
+18 SET DIC="^DIC(40.7,"
SET DIQ(0)="E"
SET DIQ="ECXDICA"
SET DR=".01;1;2"
SET DA=SCODE
DO EN^DIQ1
+19 SET ^TMP($JOB,"ECXBCMM","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)
+20 SET ^TMP($JOB,"ECXBCMM","ECXINVSC")=ECXINVSC
+21 SET ^TMP($JOB,"ECXBCMM","INVSC",CLIN)=""
End DoDot:1
+22 QUIT
