Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ECXBCM

ECXBCM.m

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