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

IBAECN1.m

Go to the documentation of this file.
  1. IBAECN1 ;WOIFO/SS-LTC PHASE 2 NIGHTLY JOB ; 20-FEB-02
  1. ;;2.0;INTEGRATED BILLING;**176,188**;21-MAR-94
  1. ;; Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. BILDATE() ;billing start date for Long Term Care Billing
  1. ; Means Test for LTC care billing stopped on JUNE 17,2002 /see
  1. ; STDATE^IBAECU1()/ . LTC billing for LTC care must start on
  1. ; JULY 26,2002. There is no billing for LTC care in period
  1. ; between JUNE 17,2002 and JULY 26,2002. That means LTC clock
  1. ; will start on JULY 5,2002 (because of 21 "free" days)
  1. Q 3020705 ;
  1. ;
  1. NJ ;LTC Nightly job
  1. N X I $D(^%ZOSF("TRAP")) S X="ERR^IBAECN1",@^("TRAP")
  1. N IBPRMNTH S IBPRMNTH=$$PREVMNTH^IBAECM1() ;last day of previous month
  1. Q:$$BILDATE()>IBPRMNTH
  1. ;
  1. N IBLSTMJ S IBLSTMJ=$$LASTMJ^IBAECU()
  1. ;run code for the 1st monthly job
  1. I IBLSTMJ=0 D MJ1ST^IBAECM3 Q
  1. ;if was run & successfully completed this month- quit
  1. Q:IBLSTMJ'<($E($$TODAY(),1,5)_"01")
  1. ;------- local arrays
  1. ;IBMDS1(0)-1st,IBMDS1(1) last day in the month,
  1. ;IBMDS1(2)-year_month, IBMDS1 - number of days
  1. N IBMDS1 S IBMDS1=""
  1. ;dates,days for processing month which is normally
  1. ; previous month because MJ runs 1stday of the month
  1. S IBMDS1(1)=IBPRMNTH,IBMDS1(2)=$E(IBMDS1(1),1,5)
  1. S IBMDS1(0)=IBMDS1(2)_"01",IBMDS1=$E(IBMDS1(1),6,7)
  1. D MJT^IBAECM1
  1. D RESET
  1. Q
  1. ;
  1. ERR ;Error trap for NJ
  1. N XMSUB,XMTEXT,XMY,XMZ,XMMG,IBL,IBT,XMDUZ,IBPAT,IBTODAY
  1. N XMGROUP S XMGROUP=$$GET1^DIQ(350.9,"1,",.09)
  1. Q:XMGROUP=""
  1. S XMGROUP="G."_XMGROUP
  1. S IBPAT="Unknown",IBTODAY=""
  1. N Y D NOW^%DTC S Y=% X ^DD("DD") S IBTODAY=Y
  1. I +$G(DFN)>0 D
  1. . N VADM,VA,VAERR
  1. . D DEM^VADPT
  1. . S IBPAT=$G(VADM(1))_", SSN: "_$P($G(VADM(2)),"^",2)
  1. S:IBPAT=", SSN: " IBPAT="Unknown"
  1. S XMSUB="LTC Monthly Job Failure",XMY(XMGROUP)=""
  1. S XMTEXT="IBT(",XMDUZ="INTEGRATED BILLING PACKAGE"
  1. S IBT(1,0)="**********************************************"
  1. S IBT(2,0)="LTC Monthly Job crashed on "_IBTODAY
  1. S IBT(3,0)="when the system was processing the following patient : "
  1. S IBT(4,0)=" "_IBPAT
  1. S IBT(5,0)="Please verify data for the patient, fix findings"
  1. S IBT(6,0)="and then:"
  1. S IBT(7,0)="- if today is the last day of the month then you"
  1. S IBT(8,0)=" need to run NJ^IBAECN1 today manually from"
  1. S IBT(9,0)=" programmer mode."
  1. S IBT(10,0)="- otherwise let the system run the NJ^IBAECN1"
  1. S IBT(11,0)=" automatically after midnight."
  1. S IBT(12,0)=""
  1. S IBT(13,0)="In both cases, please, check patient's charges and"
  1. S IBT(14,0)="your e-mail again."
  1. D ^XMD
  1. Q
  1. ;
  1. ;checks if the most recent treating specialty of the admission
  1. ;is related to LTC?
  1. ;invoked from PROC^IBAMTC Exmpl:
  1. ; I $$ISLTCADM(DFN,IBA)
  1. ;to create entries in 351.81 if necessary
  1. ;Input:
  1. ;IBDFN - patient's ien in file (#2)
  1. ;IB405 - ien of admission (#405)
  1. ;Output:
  1. ;returns 0 if the specialty for non-LTC care
  1. ;otherwise - returns 1
  1. ;
  1. ISLTCADM(IBDFN,IB405) ;
  1. ;1) treat all LTC as Means Test if the legislation is not effective yet
  1. I $$YESTRDAY()<$$BILDATE() Q 0
  1. N IBSPEC,IBTS
  1. S IBTS="M"
  1. ;2) determine treating specialty (TS)
  1. S IBSPEC=$$LASTTS(IBDFN,IB405) ;most recent TS (pointer #42.4)
  1. I IBSPEC>0 S IBTS=$P($$TREATSP^IBAECU2(IBSPEC),"^",1) ;is it LTC or not?
  1. I IBSPEC'>0 S IBTS="M" ;treat unknown as Means Test
  1. I IBTS="L" D Q 1 ;if TS is LTC
  1. . I $$CLOCK^IBAECU(IBDFN,$$YESTRDAY())
  1. Q 0
  1. ;finds the most recent parent entry in #350 related to admission
  1. ;Input:
  1. ;IBDFN - patient's dfn
  1. ;IBDT - the date to seek from (today)
  1. ;IBADM - admission we are seeking for
  1. ;IBSTAT = status we are seeking for
  1. ;output:
  1. ;returns ien_of_350^IB_action_type
  1. ;or "0^" if not found
  1. FIND350(IBDFN,IBDATE,IBADM,IBSTAT) ;
  1. N IB350,IBDT,IBINF,IBFL
  1. S IBFL=0,IBINF=""
  1. S IBDT=-IBDATE F S IBDT=$O(^IB("AFDT",IBDFN,IBDT)) Q:IBFL!(+IBDT=0) D
  1. . S IB350=0 F S IB350=$O(^IB("AFDT",IBDFN,IBDT,IB350)) Q:+IB350=0 D
  1. . . Q:'$D(^IB("AC",IBSTAT,IB350))
  1. . . S IBINF=$G(^IB(IB350,0))
  1. . . Q:IB350'=$P(IBINF,"^",16) ;non parent
  1. . . Q:$P($P(IBINF,"^",4),":",1)'="405" ;non inpatient
  1. . . S:$P($P(IBINF,"^",4),":",2)=IBADM IBFL=IB350
  1. Q IBFL_"^"_$P($G(IBINF),"^",3)
  1. ;
  1. ;edit #350 event entry
  1. ;IBIENCL - ien of #350
  1. ;IBLSTDT = DATE LAST BILLED
  1. ;IBADM - ien in #405
  1. STAT350(IBIENCL,IBLSTDT,IBADM) ;
  1. N IBIENS,IBFDA,IBERR,IBDFN1
  1. S IBDFN1=$P($G(^IB(IBIENCL,0)),"^",2)
  1. Q:+IBDFN1=0
  1. S IBIENS=IBIENCL_"," ; "D0,"
  1. S IBFDA(350,IBIENS,13)=+$G(DUZ)
  1. S:'$P($G(^IB(IBIENCL,0)),"^",17) IBFDA(350,IBIENS,.17)=(+$G(^DGPM(IBADM,0)))\1
  1. S IBFDA(350,IBIENS,.18)=(+$G(IBLSTDT))\1
  1. D NOW^%DTC S IBD=%
  1. S IBFDA(350,IBIENS,14)=IBD
  1. D FILE^DIE("","IBFDA","IBERR")
  1. I $D(IBERR) D
  1. . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBIENCL),"BILLING ACTION:","closing parent entry"_$G(IBERR("DIERR",1,"TEXT",1)))
  1. Q
  1. ;------
  1. ;create a new inpatient parent event entry in #350
  1. ;Input:
  1. ;DFN - patient's ien #2
  1. ;IBADMIEN - admission ien #405
  1. ;IBEVDT - event date (piece 17) for parent entry must be an admission date,
  1. ;IBNH:
  1. ; 1 - for 56 (#350.1) NHCU ADMISSION
  1. ; 93 - for 93 (#350.1) LTC ADMISSION
  1. ; 0 - all other events
  1. ;Returns:
  1. ;New ien of #350 Or 0 if not created
  1. CREV350(DFN,IBADMIEN,IBEVDT,IBNH) ;
  1. Q:IBEVDT=0 0
  1. N IBEVDA,IBSL,IBSERV
  1. S IBEVDA=0
  1. D SERV^IBAUTL2
  1. I '$D(IBSITE)!('$D(IBFAC)) D SITE^IBAUTL
  1. S IBSL="405:"_IBADMIEN
  1. ;if LTC ADMISSION set IBNHLTC
  1. I IBNH=93 N IBNHLTC S IBNHLTC=93
  1. D EVADD^IBAUTL3
  1. Q IBEVDA
  1. ;
  1. ;Find original admission ien, considering ASIH movements
  1. ;Input: ien of 405 that can be "child", for example
  1. ; we have ien of Nursing Home admission
  1. ; then patient moved to ASIH to hospital
  1. ; if IBA is ASIH hospital admission ien then call will return
  1. ; "original" Nursing Home admission's ien
  1. ;Output: ien of 405 of "original" admission
  1. ORIGADM(IBA) ;
  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. Q +Z
  1. ;
  1. ;most recent treating specialty
  1. ;input:
  1. ;IBDFN - patient ien
  1. ;IB405ADM - admission's #405 ien
  1. ;output:
  1. ;returns ien of SPECIALTY FILE (#42.4)
  1. LASTTS(IBDFN,IB405ADM) ;
  1. N IBDT6,IBSPEC
  1. S IBDT6=0
  1. S IBDT6=+$O(^DGPM("ATS",IBDFN,IB405ADM,IBDT6))
  1. Q:+IBDT6=0 -1 ;error
  1. S IBSPEC=$O(^DGPM("ATS",IBDFN,IB405ADM,IBDT6,0))
  1. Q:+IBSPEC=0 -1 ;error
  1. ;convert fac spec (45.7) -> treat spec (#42.4)
  1. S IBSPEC=+$P($G(^DIC(45.7,IBSPEC,0)),"^",2)
  1. Q:+IBSPEC=0 -1
  1. Q IBSPEC
  1. ;returns today date
  1. TODAY() ;
  1. N X
  1. D NOW^%DTC
  1. Q X
  1. ;returns yesterday date
  1. YESTRDAY() ;
  1. N X1,X2,X
  1. S X1=$$TODAY()
  1. S X2=-1
  1. D C^%DTC
  1. Q X
  1. ;returns 1 if the most recent treating specialty for this billable
  1. ;event and for this date was LTC
  1. ;DFN -patient ien
  1. ;IBEVDA - ien of event in #350
  1. ;IBDT - date
  1. ASIHORG(DFN,IBEVDA,IBDT) ;
  1. N IB405 S IB405=+$P($P($G(^IB(+IBEVDA,0)),"^",4),":",2)
  1. Q:IB405=0 0
  1. Q $$ISLTC4DT(DFN,IB405,IBDT_.2359)
  1. ;
  1. ;returns 1 if the most recent treating specialty for the admission
  1. ;and the date was LTC specialty
  1. ;otherwise returns 0 or -1
  1. ;DFN -patient ien
  1. ;IB405ADM - ien of #405
  1. ;IBDT - date
  1. ISLTC4DT(IBDFN,IB405ADM,IBDT) ;
  1. N IBDT6,IBSPEC,IBTS
  1. S IBDT6=9999999.9999999-IBDT
  1. S IBDT6=+$O(^DGPM("ATS",IBDFN,IB405ADM,IBDT6))
  1. Q:+IBDT6=0 -1 ;error
  1. S IBSPEC=$O(^DGPM("ATS",IBDFN,IB405ADM,IBDT6,0))
  1. Q:+IBSPEC=0 -1 ;error
  1. ;convert fac spec (45.7) -> treat spec (#42.4)
  1. S IBSPEC=+$P($G(^DIC(45.7,IBSPEC,0)),"^",2)
  1. I IBSPEC>0 S IBTS=$P($$TREATSP^IBAECU2(IBSPEC),"^",1) ;is it LTC or not?
  1. I IBSPEC'>0 S IBTS="M" ;unknown as Means Test
  1. I IBTS="L" Q 1 ;if TS is LTC
  1. Q 0
  1. ;
  1. RESET ; this will reset the ^xtmp global
  1. K ^XTMP("IB1010EC")
  1. S ^XTMP("IB1010EC",0)=$$FMADD^XLFDT(DT,60)_"^"_DT_"^LIST OF PATIENTS ALREADY REPORTED AS MISSING 1010EC INFO"
  1. Q
  1. ;