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