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

IBAMTC.m

Go to the documentation of this file.
  1. IBAMTC ;ALB/CPM - MEANS TEST NIGHTLY COMPILATION JOB ; 07 Jun 2021 4:17 PM
  1. ;;2.0;INTEGRATED BILLING;**34,52,70,93,100,118,115,132,150,153,137,176,215,275,321,312,457,519,549,614,703,706,630,704,760**;21-MAR-94;Build 25
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. INIT ; Entry point - initialize variables and parameters
  1. ;
  1. N X1,X2 ; IB*2.0*760
  1. ;Set Nightly task flag for Billing Clock query
  1. N IBNGHTSK
  1. S IBNGHTSK=1
  1. D CANCEL($$FMADD^XLFDT(DT,-7),$$NOW^XLFDT(),1) ; cancel copays (covid relief) IB*2.0*706
  1. S (IBY,Y)=1 D SITE^IBAUTL I Y<1 S IBY=Y D ERR G CLEAN ; moved from below IB*2.0*760
  1. D CANCCD ; cancel copays (Cleland-Dole) IB*2.0*760
  1. ;
  1. D UPDT^IBARXEPS($$FMADD^XLFDT(DT,-30),DT,1)
  1. ;
  1. D NIGHTLY^IBTRKR ; claims tracking nightly update
  1. ;
  1. D ^IBCD ; automated biller
  1. ;
  1. D RELPR^IBAMTV3 ; auto-release patient charges on hold at least 60 days
  1. ;
  1. D EN^IBOHRL ; auto-release patient charges on hold longer than 90 days
  1. ;
  1. K IBDT D BJ^IBJDE ; Automated DM extract monthly background job.
  1. ;
  1. ; - transfer pricing background job
  1. I '+$$SWSTAT^IBBAPI() D ^IBATEI1 ;IB*2.0*312
  1. ;
  1. D NIGHT^IBARXMA ; transmit copay cap info
  1. ;
  1. D NOW^%DTC S IBAFY=$$FY^IBOUTL(X),DT=X,U="^"
  1. S (IBERRN,IBWHER,IBJOB,IBY,Y)=1,IBCNT=0 K ^TMP($J,"IBAMTC")
  1. D SERV^IBAUTL2 I IBY<1 D ERR G CLEAN
  1. ;
  1. ; Compile Means Test copay and per diem charges for all inpatients
  1. ; Check PFSS Switch ;IB*2.0*312
  1. ; IB*2.0*549 Remove naked global
  1. I '+$$SWSTAT^IBBAPI() S (IBWARD,DFN)="" F S IBWARD=$O(^DPT("CN",IBWARD)) Q:IBWARD="" F S DFN=$O(^DPT("CN",IBWARD,DFN)) Q:'DFN W !,DFN S IBA=^DPT("CN",IBWARD,DFN),IBY=1 D PROC
  1. ;
  1. ;send inpatients' CV (CombatVet) expiration e-mail alert
  1. D CVEXMAIL^IBACV(DT)
  1. ;
  1. ;check & start LTC Monthly Job if necessary
  1. ; This code may need to be expanded, IF we don't ;IB*2.0*312
  1. ; implement on the 1st of the month, for a clean cut over ;IB*2.0*312
  1. I '+$$SWSTAT^IBBAPI() D NJ^IBAECN1 ;IB*2.0*312
  1. ;
  1. ;Run a nightly process to see if a Patient had the CAT I HRfS flag activated/de-activated during the past two days.
  1. ; If so generate a bulletin to IB MEANS TEST mailgroup
  1. D NIGHTLY^IBAMTS3 ;IB*2.0*614
  1. ;
  1. D EN^IBCE ; Transmit electronic bills
  1. ; Clean up expired Means Test billing clocks
  1. CLEAN S %H=+$H-1 D YMD^%DTC S IBDT=X,(IBN,DFN)=0,IBWHER=23
  1. F S DFN=$O(^IBE(351,"ACT",DFN)) Q:'DFN D
  1. . F S IBN=$O(^IBE(351,"ACT",DFN,IBN)) Q:'IBN D
  1. .. S IBY=1,X1=IBDT,(X2,IBCLDT)=+$P($G(^IBE(351,+IBN,0)),"^",3) D ^%DTC
  1. .. I X>364 S IBCLDA=IBN D CLOCKCL^IBAUTL3,ERR:IBY<1
  1. ;
  1. ; Close out incomplete events where the patient has been discharged,
  1. ; pass the related charges if they appear correct, and send a bulletin
  1. ; - also, send bulletins on old incomplete charges where there is no
  1. ; incomplete event
  1. D MAIN^IBAMTC2
  1. ;
  1. ;D ^IBAMTC1
  1. ;
  1. ; Send bulletin reporting job completion
  1. I '+$$SWSTAT^IBBAPI() D BULL^IBAMTC1 ;IB*2.0*312
  1. ;
  1. ; -- purge alerts
  1. D PURGE^IBAERR3
  1. ;
  1. ; purge HPID files -- IB*2.0*519
  1. ; IB*2.0*549 - PUR^IBCNHUT2 also checks to make sure the HL7 link is still up and
  1. ; running properly
  1. D PUR^IBCNHUT2
  1. ;
  1. ; Monitor special inpatient billing cases
  1. D BGJ^IBAMTI
  1. ;
  1. ; Print Pharmacy Copay Exemption Income Test Reminder Letters
  1. D EN^IBARXEL
  1. ;
  1. ; Send HMS extract files to AITC DMI queues
  1. D SENDEII^IBCNFSND
  1. ;
  1. ; Send info on any Duplicate Transactions that were identified or corrected (IB*2.0*630)
  1. I $D(^XTMP("IB TRANS")) D XMIT^IBAUTL9
  1. ;
  1. ; Kill variables and quit.
  1. D KILL1
  1. ;
  1. I $D(ZTQUEUED),$G(ZTSK) D KILL^%ZTLOAD
  1. ;
  1. D UPDTS ; update timestamp IB*2.0*760
  1. Q
  1. ;
  1. ;
  1. PROC ; Process all currently admitted patients.
  1. ;
  1. D IFCVEXP^IBACV(DFN,DT,IBA) ;if CV has expired (see CVEXMAIL^IBACV)
  1. ;--
  1. ;1) checks effective date for LTC legislation.
  1. ;2) determine current treating specialty (TS) for the
  1. ;"original" admission.
  1. ;if TS is LTC:
  1. ; - creates new LTC #350 parent event entry if necessary.
  1. ;NOTE: It doesn't stop MT billing for LTC. CALC^IBAUTL4 does it.
  1. I $$ISLTCADM^IBAECN1(DFN,IBA)
  1. ;--
  1. D ORIG ; find "original" admission date
  1. Q:$$BILST^DGMTUB(DFN)<IBADMDT ; pat. was last billable before admission
  1. Q:IBADMDT\1=DT ; patient was admitted today - process tomorrow
  1. Q:+$$MVT^DGPMOBS(IBA) ; admitted for Observation & Examination
  1. Q:$O(^IBE(351.2,"AC",IBA,0)) ; skip special inpatient admissions
  1. ;
  1. ; - if vet is SC, create a Special Inpatient Billing Case
  1. ; in file #351.2 (use code 3 for SC, as it is changed to 4 in IBAMTI)
  1. D ELIG^VADPT I VAEL(3) D ADM^IBAMTI(DFN,IBA,3) Q
  1. ;
  1. ; - gather event information
  1. D EVFIND^IBAUTL3 I 'IBEVDA D BSEC Q:'IBBS ; wasn't billable yesterday
  1. S X=IBADMDT D H^%DTC S IBBDT=%H D:'IBEVDA LAST^IBAUTL5
  1. I IBEVDA,IBEVCAL S X1=IBEVCAL,X2=1 D C^%DTC S IBBDT=%H
  1. S IBEDT=+$H-1
  1. ; - gather clock information
  1. S IBWHER=24 D CLOCK^IBAUTL3 I IBY<1 D ERR G PROCQ
  1. I IBCLDA S X=IBCLDT D H^%DTC S IBCLCT=IBBDT-%H
  1. ; - build charges for inpatient days
  1. D ^IBAUTL4 I IBY<1 D ERR G PROCQ
  1. ; - pass per diem if over 30 days old, or both per diem and the copay
  1. ; - if 4 days from patient's statement date; update event, clock
  1. S IBWHER=22
  1. I $G(IBCHPDA),$P($G(^IB(+IBCHPDA,0)),"^",6)>30!($$STD^IBAUTL5(DFN)) S IBNOS=IBCHPDA D FILER^IBAUTL5 I IBY<1 D ERR G PROCQ
  1. I $G(IBCHCDA),$$STD^IBAUTL5(DFN) S IBNOS=IBCHCDA D FILER^IBAUTL5 I IBY<1 D ERR G PROCQ
  1. I IBEVDA,$D(IBDT) S IBEVCLD=IBDT D EVUPD^IBAUTL3
  1. I IBCLDA D CLUPD^IBAUTL3
  1. PROCQ D KILL Q
  1. ;
  1. BSEC ; Determine patient's bed section for the previous day.
  1. S X1=DT,X2=-1 D C^%DTC
  1. S VAIP("D")=X_.2359 D IN5^VADPT S IBBS=$$SECT^IBAUTL5(+VAIP(8)) Q
  1. ;
  1. ERR ; Error processing. Input: IBY, IBWHER, IBCNT
  1. S IBDUZ=DUZ,IBCNT=IBCNT+1 D ^IBAERR1 K IBDUZ Q
  1. ;S ^TMP($J,"IBAMTC","E",IBERRN)=$P(IBY,"^",2)_"^"_$S($D(DFN):DFN,1:"")_"^"_IBWHER,IBERRN=IBERRN+1 Q
  1. ;
  1. ORIG ; Find first admission date, considering ASIH movements
  1. ; Input: IBA Output: IBADMDT
  1. N X,Y,Z S Z=IBA
  1. F S X=$G(^DGPM(Z,0)),Y=$P(X,"^",21) Q:Y="" S Z=+$P($G(^DGPM(Y,0)),"^",14)
  1. S IBADMDT=+X Q
  1. ;
  1. CANCEL(STRTDT,ENDDT,MSG) ; cancel copays (covid relief) IB*2.0*703
  1. ;
  1. ; STRTDT - starting date (internal)
  1. ; ENDDT - ending date (internal)
  1. ; MSG - 0 to skip Mailman bulletin, 1 to send full Mailman bulletin, 2 to send only error report
  1. ;
  1. N IBACT,IBCRES,IBDTM,IBECODE,IBEMSG,IBFR,IBIEN,IBN0,IBRES,IBSRVFR,IBSRVTO,IBSTAT,IBTO,IBXA,STATSTR
  1. ; service dates
  1. S IBSRVFR=3200406 ; start date 04/06/20
  1. S IBSRVTO=$P(^IBE(350.9,1,71),U) ; end date comes from 350.9/71.01
  1. S STATSTR="^BILLED^HOLD - RATE^HOLD - REVIEW^INCOMPLETE^ON HOLD^" ; bill statuses to include IB*2.0*703
  1. ;
  1. I MSG K ^TMP("IBAMTC3",$J)
  1. S IBDTM=STRTDT F S IBDTM=$O(^IB("D",IBDTM)) Q:'IBDTM!(IBDTM'<ENDDT) D
  1. .S IBIEN=0 F S IBIEN=$O(^IB("D",IBDTM,IBIEN)) Q:'IBIEN D
  1. ..S IBN0=^IB(IBIEN,0) ; file 350, node 0
  1. ..S IBSTAT=$$GET1^DIQ(350,IBIEN_",",.05) ; status from 350/.05 (external)
  1. ..I STATSTR'[(U_IBSTAT_U) Q ; only cancel copays with specific status IB*2.0*703
  1. ..S IBACT=$G(^IBE(350.1,+$P(IBN0,U,3),0)) ; node 0 in file 350.1 for the action type of this charge
  1. ..I $P(IBACT,U,5)'=1 Q ; action type is not "New"
  1. ..S IBXA=$P(IBACT,U,11) ; billing group
  1. ..I IBXA=6!(IBXA=7) Q ; skip CHAMPVA/TRICARE charges
  1. ..I IBSTAT="INCOMPLETE",IBXA=4!(IBXA=5) Q
  1. ..S IBFR=+$P(IBN0,U,14) I IBFR>IBSRVTO Q ; Bill From date is outside the range
  1. ..S IBTO=+$P(IBN0,U,15) I IBTO<IBSRVFR Q ; Bill To date is outside the range
  1. ..; cancel this copay with "pandemic response" reason
  1. ..S IBCRES=$O(^IBE(350.3,"B","PANDEMIC RESPONSE",0))
  1. ..S IBRES=$$CANCEL^IBECEAU6(IBIEN,IBCRES,0,0)
  1. ..I MSG>0 D
  1. ...I +IBRES<0 D Q
  1. ....S IBECODE=$P(IBRES,U,2),IBEMSG=$S(IBECODE'="":$P($G(^IBE(350.8,+$O(^IBE(350.8,"AC",$P(IBECODE,";"),0)),0)),U,2),1:$P(IBRES,U,3))
  1. ....S ^TMP("IBAMTC3",$J,0,$P(IBN0,U))=$P(IBN0,U,11)_U_IBEMSG Q
  1. ....Q
  1. ...I MSG<2 S ^TMP("IBAMTC3",$J,1,$P(IBN0,U))=$P(IBN0,U,11)
  1. ..Q
  1. .Q
  1. ; send Mailman bulletin
  1. I MSG D CANCBLTN^IBAMTC3 K ^TMP("IBAMTC3",$J)
  1. Q
  1. ;
  1. KILL1 ; Kill all IB variables.
  1. K VAERR,VAEL,VAIP,IBA,IBADMDT,IBAFY,IBATYP,IBBDT,IBBS,IBCHARG,IBCHG,IBCNT,IBCUR,IBDESC,IBDISDT,IBDT,IBDUZ,IBFAC,IBI,IBIL,IBJOB,IBLC,IBMAX
  1. K IBN,IBNOS,IBSAVBS,IBSEQNO,IBSERV,IBSITE,IBSL,IBTRAN,IBX,IBY,IBWHER,IBWARD,IBEDT,IBCHCTY,IBCHPDE,IBERRN,IBASIH,IBRTED
  1. KILL ; Kill all IB variables needed to build charges.
  1. K IBCLCT,IBCLDA,IBCLDT,IBCLDAY,IBCLDOL,IBCHPDA,IBCHCDA,IBCHG,IBCHFR,IBCHTO,IBCHTOTL,IBBS,IBNH
  1. K IBEVDA,IBEVDT,IBEVCLD,IBEVCAL,IBEVNEW,IBEVOLD,IBMED,IBTOTL,IBDESC,IBIL,IBTRAN,IBATYP,IBDATE
  1. Q
  1. ;
  1. UPDTS ; update completion timestamp (350.9/.17) IB*2.0*760
  1. N FDA
  1. S FDA(350.9,"1,",.17)=$$NOW^XLFDT()
  1. D FILE^DIE("","FDA")
  1. Q
  1. ;
  1. CANCCD ; cancel copays (Cleland-Dole) IB*2.0*760
  1. N DFN,IBCRES,IBDTM,IBERROR,IBEVDT,IBFREE,IBIEN,IBIEN1,IBN0,IBRTN,IBSTAT,IBVSTIEN,IBVSTAT,STATSTR,Z
  1. S STATSTR="^BILLED^HOLD - RATE^HOLD - REVIEW^ON HOLD^" ; bill statuses to include
  1. S IBDTM=$$GET1^DIQ(350.9,"1,",.17,"I") I IBDTM'>0 S IBDTM=$$FMADD^XLFDT(DT,-1)
  1. F S IBDTM=$O(^IB("D",IBDTM)) Q:'IBDTM D
  1. .S IBIEN=0 F S IBIEN=$O(^IB("D",IBDTM,IBIEN)) Q:'IBIEN D
  1. ..S IBN0=^IB(IBIEN,0) ; file 350, node 0
  1. ..S IBIEN1=$P(IBN0,U,9) ; parent charge ien
  1. ..I IBIEN'=IBIEN1 Q ; not the parent charge
  1. ..S IBSTAT=$$GET1^DIQ(350,IBIEN_",",.05) ; status from 350/.05 (external)
  1. ..I STATSTR'[(U_IBSTAT_U) Q ; only cancel copays with specific status
  1. ..S IBACT=$G(^IBE(350.1,+$P(IBN0,U,3),0)) ; node 0 in file 350.1 for the action type of this charge
  1. ..I $P(IBACT,U,5)'=1 Q ; action type is not "New"
  1. ..I $$ISCMPCT(IBIEN) Q ; COMPACT Act related
  1. ..I '$$ISCLDL(IBIEN) Q ; not Cleland-Dole eligible
  1. ..S DFN=$P(IBN0,U,2),IBEVDT=$P(IBN0,U,17)
  1. ..S IBCRES=$O(^IBE(350.3,"B","CLELAND-DOLE",0))
  1. ..S Z=$$FNDMHVST(DFN,IBEVDT),IBVSTIEN=$P(Z,U),IBVSTAT=$P(Z,U,2) ; find exisiting visit
  1. ..S IBFREE=$$GETMHFR(DFN,IBEVDT) ; 1 if there's a free visit on this date
  1. ..I IBFREE D Q
  1. ...S IBRTN=$$CANCEL^IBECEAU6(IBIEN,IBCRES,0,0) ; cancel this copay with "Cleland-Dole" reason
  1. ...I IBVSTIEN,IBVSTAT'=1 S IBRTN=$$UPDATE^IBECEAMH(1,IBVSTIEN,4,"",2,1,.IBERROR) ; update to visit only
  1. ...Q
  1. ..; check if there are free visits available
  1. ..I $$NUMVSTCK^IBECEAMH(DFN,IBEVDT) D Q
  1. ...S IBRTN=$$CANCEL^IBECEAU6(IBIEN,IBCRES,0,0) ; cancel this copay with "Cleland-Dole" reason
  1. ...I IBVSTIEN,IBVSTAT'=1 S IBRTN=$$UPDATE^IBECEAMH(1,IBVSTIEN,1,"",2,1,.IBERROR) Q ; update to free visit
  1. ...; if there's no visit for this date, add a free visit
  1. ...I 'IBVSTIEN D ADDVST^IBECEAMH(DFN,IBEVDT,"",1,2)
  1. ...Q
  1. ..I $O(^IBMH(351.83,"D",IBIEN,"")) Q ; corresponding MH visit entry already exists
  1. ..D ADDVST^IBECEAMH(DFN,IBEVDT,IBIEN,2) ; add "billed" MH visit entry
  1. ..Q
  1. .Q
  1. Q
  1. ;
  1. UPDCANC(IBIEN) ; update MH visit tracking for cancelled copay
  1. N IBERROR,IBRTN,IBSTAT,IBVSTIEN
  1. I 'IBIEN Q
  1. S IBSTAT=$$GET1^DIQ(350,IBIEN_",",.05) ; status from 350/.05 (external)
  1. I IBSTAT="CANCELLED" D
  1. .; if there's a "billed" visit tracking entry linked to a cancelled copay, change that entry to "visit only" / "duplicate visit" reason
  1. .S IBVSTIEN=$O(^IBMH(351.83,"D",IBIEN,"")) I 'IBVSTIEN Q
  1. .I $P(^IBMH(351.83,IBVSTIEN,0),U,4)=2 S IBRTN=$$UPDATE^IBECEAMH(1,IBVSTIEN,4,"",4,1,.IBERROR)
  1. .Q
  1. Q
  1. ;
  1. FNDMHVST(DFN,IBEVDT) ; find existing MH visit on a given date IB*2.0*760
  1. ;
  1. ; DFN - patient's DFN
  1. ; IBEVDT - date to search for (internal)
  1. ;
  1. ; returns "file 351.83 ien ^ visit status (351.83/.04)" if visit was found, 0 otherwise
  1. ;
  1. N IBSTAT,IBVSTIEN,RES
  1. I $G(IBEVDT)'>0!$G(DFN)'>0 Q 0
  1. S RES=0
  1. S IBVSTIEN="" F S IBVSTIEN=$O(^IBMH(351.83,"VD",IBEVDT,IBVSTIEN),-1) Q:'IBVSTIEN!+RES D
  1. .I '$D(^IBMH(351.83,"B",DFN,IBVSTIEN)) Q ; different patient
  1. .S IBSTAT=$P(^IBMH(351.83,IBVSTIEN,0),U,4) I IBSTAT=3 Q ; removed visit
  1. .S RES=IBVSTIEN_U_IBSTAT
  1. .Q
  1. Q RES
  1. ;
  1. GETMHFR(DFN,IBEVDT) ; check if there's an existing free MH visit on a given date IB*2.0*760
  1. ;
  1. ; DFN - patient's DFN
  1. ; IBEVDT - date to search for (internal)
  1. ;
  1. ; returns 1 if free visit was found, 0 otherwise
  1. ;
  1. N IBSTAT,IBVSTIEN,RES
  1. I $G(IBEVDT)'>0!$G(DFN)'>0 Q 0
  1. S RES=0
  1. S IBVSTIEN="" F S IBVSTIEN=$O(^IBMH(351.83,"VD",IBEVDT,IBVSTIEN),-1) Q:'IBVSTIEN!+RES D
  1. .I '$D(^IBMH(351.83,"B",DFN,IBVSTIEN)) Q ; different patient
  1. .S IBSTAT=$P(^IBMH(351.83,IBVSTIEN,0),U,4) I IBSTAT'=1 Q ; not a free visit
  1. .S RES=1
  1. .Q
  1. Q RES
  1. ;
  1. ISCLDL(IBN) ; check if charge is Cleland-Dole eligible IB*2.0*760
  1. ;
  1. ; IBN - file 350 ien
  1. ;
  1. ; returns 1 if charge is Cleland-Dole eligible, 0 otherwise
  1. ;
  1. N IBATYP,IBATYPN,IBDATA,RES,Z
  1. S RES=0 I $G(IBN)'>0 Q 0 ; invalid ien
  1. S IBDATA=$G(^IB(IBN,0))
  1. S IBATYP=$P(IBDATA,U,3) I 'IBATYP Q 0
  1. S IBATYPN=$P($G(^IBE(350.1,IBATYP,0)),U) I IBATYPN'["OPT" Q 0 ; not an outpatient charge
  1. I IBATYPN["CC MH" Q 1
  1. I $$ISCDCANC^IBECEAMH(IBN) Q 1
  1. S Z=$P($P(IBDATA,U,4),";") I $P(Z,":")'="409.68" Q 0
  1. Q $$OECHK^IBECEAMH($P(Z,":",2),$P(IBDATA,U,17))
  1. ;
  1. ISCMPCT(IBN) ; check if charge is COMPACT Act related IB*2.0*760
  1. ;
  1. ; IBN - file 350 ien
  1. ;
  1. ; returns 1 if charge is COMPACT Act related, 0 otherwise
  1. ;
  1. N DFN,IBCHTYPE,I,IBCPTARY,IBDATA,IBDXARY,IBDXLIST,IBPCE,IBRF,IBRFFL,RES
  1. S RES=0 I $G(IBN)'>0 Q RES ; invalid ien
  1. S IBDATA=$G(^IB(IBN,0))
  1. S DFN=$P(IBDATA,U,2) I '$$ISELIG^IBOMHC(DFN) Q RES ; patient is not eligible
  1. ; parse "resulting from" field
  1. S IBRF=$P(IBDATA,U,4) I IBRF'[":" Q RES
  1. S IBRFFL=$P(IBRF,":")
  1. ;
  1. S IBCHTYPE=$P(IBDATA,U,3) I IBCHTYPE="" Q RES
  1. I $$GET1^DIQ(350.1,IBCHTYPE,.05,"E")'="NEW" Q RES
  1. ; If RX copay, quit.
  1. I $$GET1^DIQ(350.1,IBCHTYPE,.11,"I")=5 Q RES
  1. D GETDX(.IBDXLIST)
  1. ; If file is 45 (PTF), lookup the primary and Secondary diagnoses
  1. I IBRFFL=45 D GETPTFDX^IBOMHC($P(IBRF,":",2),.IBDXARY)
  1. ; If file is 409.68, lookup the diagnoses using OPTDX^IBCSC4D
  1. I IBRFFL=409.68 S IBPCE=$P(IBRF,":",2) D GETPCEDX^IBOMHC(IBPCE,.IBDXARY),GETPCECP^IBOMHC(IBPCE,.IBCPTARY)
  1. ; If file is 405, grab the PTF or Diagnoses Text Strings.
  1. I IBRFFL=405 D GETPMDX^IBOMHC($P(IBRF,":",2),.IBDXARY)
  1. S I="" F S I=$O(IBDXARY(I)) Q:I="" D Q:RES
  1. .I $D(IBCPTARY("T2034")) S RES=1 Q ; If there's T2034 cpt code, copay is eligible
  1. .I I="R45.851",$D(IBCPTARY("80939")) S RES=1 Q ; If Dx is R45.851 and CPT code is 80939, copay is eligible
  1. .I $D(IBDXLIST(I)) S RES=1 ; If Dx is one the list, copay is eligible
  1. .Q
  1. Q RES
  1. ;
  1. GETDX(IBDXLIST) ; Populate the list of Comact Act eligible DX codes IB*2.0*760
  1. ;
  1. ; IBDLIST - resulting array of Dx codes, passed by reference
  1. ;
  1. N I,IBDATA,IBDXD
  1. ; Retrieve Specific Diagnosis codes
  1. F I=1:1 S IBDATA=$T(DXSLIST+I) S IBDXD=$P(IBDATA,";",3) Q:IBDXD="EXIT" S IBDXLIST(IBDXD)=0
  1. ;
  1. Q
  1. ;
  1. DXSLIST ; List of Specific Compact Act Related Diagnosis codes IB*2.0*760
  1. ;;T14.91XA
  1. ;;T14.91XD
  1. ;;T14.91XS
  1. ;;EXIT
  1. Q