- 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 Feb 18, 2025@23:18:40 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