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

IBAECM3.m

Go to the documentation of this file.
  1. IBAECM3 ;WOIFO/SS-LTC PHASE 2 MONTHLY JOB PART 3 ; 20-FEB-02
  1. ;;2.0;INTEGRATED BILLING;**176**;21-MAR-94
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. MJ1ST ;entry for the first Monthly Calculation Process
  1. N IBMDS1
  1. ;------ variables
  1. N IBMJ1ST S IBMJ1ST="MJ1ST" ;to identify 1st MJ in IBAECU4
  1. N IBPRMNTH S IBPRMNTH=$$PREVMNTH^IBAECM1() ;last day of previous month
  1. N IBCLKAD1 ; variable to return back from PROCPAT info for clock adjustment
  1. N IBDFN,IBMNS,IBVAR
  1. N IBCLKIE1
  1. N IBCLKDAT ;clock data
  1. N IBSTRTD ;EFFECTIVE DATE
  1. S (IBMNS,IBMDS1)=""
  1. S IBSTRTD=$$BILDATE^IBAECN1()
  1. K ^TMP($J,"IBMJERR")
  1. K ^TMP($J,"IBMJINP")
  1. K ^TMP($J,"IBMJOUT")
  1. ;prepare arrays for months since the effective date
  1. D PRMONTHS(.IBMNS,IBPRMNTH)
  1. ;go thru all patients in #351.81
  1. S IBDFN1=0
  1. ;for each patient in file 351.81
  1. F S IBDFN1=$O(^IBA(351.81,"C",IBDFN1)) Q:+IBDFN1=0 D
  1. . S IBCLKIE1=0,IBERR=""
  1. . F S IBCLKIE1=+$O(^IBA(351.81,"C",IBDFN1,IBCLKIE1)) Q:+IBCLKIE1=0 D
  1. . . S IBCLKDAT=^IBA(351.81,IBCLKIE1,0)
  1. . . ; quit if STATUS'=OPEN
  1. . . Q:$P(IBCLKDAT,"^",5)'=1
  1. . . ; quit if CURRENT EVENTS DATE="" i.e. no LTC events happend
  1. . . ; this month for the patient
  1. . . Q:$P(IBCLKDAT,"^",7)=""
  1. . . ; quit if CURRENT EVENTS DATE>last day of "real-time" previous month -the veteran
  1. . . ; has been processed for all months in the past
  1. . . Q:$P(IBCLKDAT,"^",7)>IBPRMNTH
  1. . . ; if error save it in ^TMP for further e-mail
  1. . . S IBCLKAD1=""
  1. . . ;process the patient
  1. . . S IBVAR=0
  1. . . F S IBVAR=$O(IBMNS(IBVAR)) Q:+IBVAR=0 D
  1. . . . Q:$$CHKXTMP(IBDFN1,IBVAR) ;check if it was a crush and the month has been already processed
  1. . . . M IBMDS1=IBMNS(IBVAR) ;set month to process
  1. . . . S IBMDS1=$E(IBMDS1(1),6,7)
  1. . . . D CHNGEVEN^IBAECU4(IBCLKIE1,IBDFN1,IBMDS1(0)) ;set CURRENT EVENT DATE to a date of the MONTH (say,1st day)
  1. . . . I $$PROCPAT^IBAECM2(.IBMDS1,IBDFN1,IBSTRTD,IBCLKIE1)=-1 D ;perform calcualtion
  1. . . . . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBCLKIE1),"Charge","Error with LTC clock creation occured during calculation, no proper charges have been created") Q
  1. . . . D UPDXTMP(IBDFN1,IBVAR) ;mark the month as done
  1. . . D DELXTMP(IBDFN1)
  1. ;send all errors to user group
  1. D SENDERR^IBAECU5 ;send all errors
  1. ;if we reach this place that means that we processed everybody
  1. ;and we stamp the date into IB SITE PARAMETERS
  1. S $P(^IBE(350.9,1,0),"^",16)=$$TODAY^IBAECN1()
  1. ;if Nightly Job founds that date $P(^IBE(350.9,1,0),"^",16)
  1. ;is less that begining of current month than NJ runs MJ again and MJ will
  1. ;process a rest patients
  1. D KILLXTMP ;delete ^XTMP
  1. Q
  1. ;IBALLM - Array with month info
  1. ; IBALLM (0)-first day of the month
  1. ; IBALLM (1)-last day of the month
  1. ; IBALLM (2)-yyymm in Fileman format (like 30201 - for Jan 2002)
  1. ;IBPRMNTH -Last day of the last mont
  1. PRMONTHS(IBALLM,IBPRMNTH) ;prepare months
  1. S IBALLM=""
  1. N X,IB176YM,IB176TMP
  1. S IB176YM=$E($$BILDATE^IBAECN1(),1,5)
  1. F Q:IB176YM>$E(IBPRMNTH,1,5) D
  1. . S X=IB176YM_"01"
  1. . S IBALLM(IB176YM,1)=$$LASTDT^IBAECU(X)
  1. . S IBALLM(IB176YM,2)=$E(IBALLM(IB176YM,1),1,5)
  1. . S IBALLM(IB176YM,0)=IBALLM(IB176YM,2)_"01",IBALLM=$E(IBALLM(IB176YM,1),6,7)
  1. . I +$E(IB176YM,4,5)=12 S IB176YM=$E(IB176YM,1,3)+1,IB176YM=IB176YM_"01" Q
  1. . S IB176YM=IB176YM+1
  1. Q
  1. ;
  1. KILLXTMP ;
  1. K ^XTMP("IBAEC-P176")
  1. Q
  1. ;
  1. ;IBDFN - ien of #2
  1. ;IBYM - year_month in yyymm format
  1. CHKXTMP(IBDFN,IBYM) ;check if ^XTMP for the patient and month is exist
  1. Q $D(^XTMP("IBAEC-P176",IBDFN,IBYM))>0
  1. ;
  1. ;IBDFN - ien of #2
  1. ;IBYM - year_month in yyymm format
  1. UPDXTMP(IBDFN,IBYM) ;update XTMP with new info
  1. N IBDT S IBDT=$$TODAY^IBAECN1()
  1. S ^XTMP("IBAEC-P176",0)=$$CHNGDATE^IBAECU4(IBDT,30)_"^"_IBDT_"^1st LTC copay calculation"
  1. S ^XTMP("IBAEC-P176",+IBDFN,IBYM)=""
  1. Q
  1. ;
  1. ;IBDFN - ien of #2
  1. DELXTMP(IBDFN) ;Kills ^XTMP node for the patient.
  1. K ^XTMP("IBAEC-P176",+IBDFN)
  1. Q
  1. ;