IBAECM3 ;WOIFO/SS-LTC PHASE 2 MONTHLY JOB PART 3 ; 20-FEB-02
;;2.0;INTEGRATED BILLING;**176**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
MJ1ST ;entry for the first Monthly Calculation Process
N IBMDS1
;------ variables
N IBMJ1ST S IBMJ1ST="MJ1ST" ;to identify 1st MJ in IBAECU4
N IBPRMNTH S IBPRMNTH=$$PREVMNTH^IBAECM1() ;last day of previous month
N IBCLKAD1 ; variable to return back from PROCPAT info for clock adjustment
N IBDFN,IBMNS,IBVAR
N IBCLKIE1
N IBCLKDAT ;clock data
N IBSTRTD ;EFFECTIVE DATE
S (IBMNS,IBMDS1)=""
S IBSTRTD=$$BILDATE^IBAECN1()
K ^TMP($J,"IBMJERR")
K ^TMP($J,"IBMJINP")
K ^TMP($J,"IBMJOUT")
;prepare arrays for months since the effective date
D PRMONTHS(.IBMNS,IBPRMNTH)
;go thru all patients in #351.81
S IBDFN1=0
;for each patient in file 351.81
F S IBDFN1=$O(^IBA(351.81,"C",IBDFN1)) Q:+IBDFN1=0 D
. S IBCLKIE1=0,IBERR=""
. F S IBCLKIE1=+$O(^IBA(351.81,"C",IBDFN1,IBCLKIE1)) Q:+IBCLKIE1=0 D
. . S IBCLKDAT=^IBA(351.81,IBCLKIE1,0)
. . ; quit if STATUS'=OPEN
. . Q:$P(IBCLKDAT,"^",5)'=1
. . ; quit if CURRENT EVENTS DATE="" i.e. no LTC events happend
. . ; this month for the patient
. . Q:$P(IBCLKDAT,"^",7)=""
. . ; quit if CURRENT EVENTS DATE>last day of "real-time" previous month -the veteran
. . ; has been processed for all months in the past
. . Q:$P(IBCLKDAT,"^",7)>IBPRMNTH
. . ; if error save it in ^TMP for further e-mail
. . S IBCLKAD1=""
. . ;process the patient
. . S IBVAR=0
. . F S IBVAR=$O(IBMNS(IBVAR)) Q:+IBVAR=0 D
. . . Q:$$CHKXTMP(IBDFN1,IBVAR) ;check if it was a crush and the month has been already processed
. . . M IBMDS1=IBMNS(IBVAR) ;set month to process
. . . S IBMDS1=$E(IBMDS1(1),6,7)
. . . D CHNGEVEN^IBAECU4(IBCLKIE1,IBDFN1,IBMDS1(0)) ;set CURRENT EVENT DATE to a date of the MONTH (say,1st day)
. . . I $$PROCPAT^IBAECM2(.IBMDS1,IBDFN1,IBSTRTD,IBCLKIE1)=-1 D ;perform calcualtion
. . . . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBCLKIE1),"Charge","Error with LTC clock creation occured during calculation, no proper charges have been created") Q
. . . D UPDXTMP(IBDFN1,IBVAR) ;mark the month as done
. . D DELXTMP(IBDFN1)
;send all errors to user group
D SENDERR^IBAECU5 ;send all errors
;if we reach this place that means that we processed everybody
;and we stamp the date into IB SITE PARAMETERS
S $P(^IBE(350.9,1,0),"^",16)=$$TODAY^IBAECN1()
;if Nightly Job founds that date $P(^IBE(350.9,1,0),"^",16)
;is less that begining of current month than NJ runs MJ again and MJ will
;process a rest patients
D KILLXTMP ;delete ^XTMP
Q
;IBALLM - Array with month info
; IBALLM (0)-first day of the month
; IBALLM (1)-last day of the month
; IBALLM (2)-yyymm in Fileman format (like 30201 - for Jan 2002)
;IBPRMNTH -Last day of the last mont
PRMONTHS(IBALLM,IBPRMNTH) ;prepare months
S IBALLM=""
N X,IB176YM,IB176TMP
S IB176YM=$E($$BILDATE^IBAECN1(),1,5)
F Q:IB176YM>$E(IBPRMNTH,1,5) D
. S X=IB176YM_"01"
. S IBALLM(IB176YM,1)=$$LASTDT^IBAECU(X)
. S IBALLM(IB176YM,2)=$E(IBALLM(IB176YM,1),1,5)
. S IBALLM(IB176YM,0)=IBALLM(IB176YM,2)_"01",IBALLM=$E(IBALLM(IB176YM,1),6,7)
. I +$E(IB176YM,4,5)=12 S IB176YM=$E(IB176YM,1,3)+1,IB176YM=IB176YM_"01" Q
. S IB176YM=IB176YM+1
Q
;
KILLXTMP ;
K ^XTMP("IBAEC-P176")
Q
;
;IBDFN - ien of #2
;IBYM - year_month in yyymm format
CHKXTMP(IBDFN,IBYM) ;check if ^XTMP for the patient and month is exist
Q $D(^XTMP("IBAEC-P176",IBDFN,IBYM))>0
;
;IBDFN - ien of #2
;IBYM - year_month in yyymm format
UPDXTMP(IBDFN,IBYM) ;update XTMP with new info
N IBDT S IBDT=$$TODAY^IBAECN1()
S ^XTMP("IBAEC-P176",0)=$$CHNGDATE^IBAECU4(IBDT,30)_"^"_IBDT_"^1st LTC copay calculation"
S ^XTMP("IBAEC-P176",+IBDFN,IBYM)=""
Q
;
;IBDFN - ien of #2
DELXTMP(IBDFN) ;Kills ^XTMP node for the patient.
K ^XTMP("IBAEC-P176",+IBDFN)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAECM3 3936 printed Oct 16, 2024@18:06:43 Page 2
IBAECM3 ;WOIFO/SS-LTC PHASE 2 MONTHLY JOB PART 3 ; 20-FEB-02
+1 ;;2.0;INTEGRATED BILLING;**176**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
MJ1ST ;entry for the first Monthly Calculation Process
+1 NEW IBMDS1
+2 ;------ variables
+3 ;to identify 1st MJ in IBAECU4
NEW IBMJ1ST
SET IBMJ1ST="MJ1ST"
+4 ;last day of previous month
NEW IBPRMNTH
SET IBPRMNTH=$$PREVMNTH^IBAECM1()
+5 ; variable to return back from PROCPAT info for clock adjustment
NEW IBCLKAD1
+6 NEW IBDFN,IBMNS,IBVAR
+7 NEW IBCLKIE1
+8 ;clock data
NEW IBCLKDAT
+9 ;EFFECTIVE DATE
NEW IBSTRTD
+10 SET (IBMNS,IBMDS1)=""
+11 SET IBSTRTD=$$BILDATE^IBAECN1()
+12 KILL ^TMP($JOB,"IBMJERR")
+13 KILL ^TMP($JOB,"IBMJINP")
+14 KILL ^TMP($JOB,"IBMJOUT")
+15 ;prepare arrays for months since the effective date
+16 DO PRMONTHS(.IBMNS,IBPRMNTH)
+17 ;go thru all patients in #351.81
+18 SET IBDFN1=0
+19 ;for each patient in file 351.81
+20 FOR
SET IBDFN1=$ORDER(^IBA(351.81,"C",IBDFN1))
if +IBDFN1=0
QUIT
Begin DoDot:1
+21 SET IBCLKIE1=0
SET IBERR=""
+22 FOR
SET IBCLKIE1=+$ORDER(^IBA(351.81,"C",IBDFN1,IBCLKIE1))
if +IBCLKIE1=0
QUIT
Begin DoDot:2
+23 SET IBCLKDAT=^IBA(351.81,IBCLKIE1,0)
+24 ; quit if STATUS'=OPEN
+25 if $PIECE(IBCLKDAT,"^",5)'=1
QUIT
+26 ; quit if CURRENT EVENTS DATE="" i.e. no LTC events happend
+27 ; this month for the patient
+28 if $PIECE(IBCLKDAT,"^",7)=""
QUIT
+29 ; quit if CURRENT EVENTS DATE>last day of "real-time" previous month -the veteran
+30 ; has been processed for all months in the past
+31 if $PIECE(IBCLKDAT,"^",7)>IBPRMNTH
QUIT
+32 ; if error save it in ^TMP for further e-mail
+33 SET IBCLKAD1=""
+34 ;process the patient
+35 SET IBVAR=0
+36 FOR
SET IBVAR=$ORDER(IBMNS(IBVAR))
if +IBVAR=0
QUIT
Begin DoDot:3
+37 ;check if it was a crush and the month has been already processed
if $$CHKXTMP(IBDFN1,IBVAR)
QUIT
+38 ;set month to process
MERGE IBMDS1=IBMNS(IBVAR)
+39 SET IBMDS1=$EXTRACT(IBMDS1(1),6,7)
+40 ;set CURRENT EVENT DATE to a date of the MONTH (say,1st day)
DO CHNGEVEN^IBAECU4(IBCLKIE1,IBDFN1,IBMDS1(0))
+41 ;perform calcualtion
IF $$PROCPAT^IBAECM2(.IBMDS1,IBDFN1,IBSTRTD,IBCLKIE1)=-1
Begin DoDot:4
+42 DO ERRLOG^IBAECU5(+$GET(IBDFN1),+$GET(IBCLKIE1),"Charge","Error with LTC clock creation occured during calculation, no proper charges have been created")
QUIT
End DoDot:4
+43 ;mark the month as done
DO UPDXTMP(IBDFN1,IBVAR)
End DoDot:3
+44 DO DELXTMP(IBDFN1)
End DoDot:2
End DoDot:1
+45 ;send all errors to user group
+46 ;send all errors
DO SENDERR^IBAECU5
+47 ;if we reach this place that means that we processed everybody
+48 ;and we stamp the date into IB SITE PARAMETERS
+49 SET $PIECE(^IBE(350.9,1,0),"^",16)=$$TODAY^IBAECN1()
+50 ;if Nightly Job founds that date $P(^IBE(350.9,1,0),"^",16)
+51 ;is less that begining of current month than NJ runs MJ again and MJ will
+52 ;process a rest patients
+53 ;delete ^XTMP
DO KILLXTMP
+54 QUIT
+55 ;IBALLM - Array with month info
+56 ; IBALLM (0)-first day of the month
+57 ; IBALLM (1)-last day of the month
+58 ; IBALLM (2)-yyymm in Fileman format (like 30201 - for Jan 2002)
+59 ;IBPRMNTH -Last day of the last mont
PRMONTHS(IBALLM,IBPRMNTH) ;prepare months
+1 SET IBALLM=""
+2 NEW X,IB176YM,IB176TMP
+3 SET IB176YM=$EXTRACT($$BILDATE^IBAECN1(),1,5)
+4 FOR
if IB176YM>$EXTRACT(IBPRMNTH,1,5)
QUIT
Begin DoDot:1
+5 SET X=IB176YM_"01"
+6 SET IBALLM(IB176YM,1)=$$LASTDT^IBAECU(X)
+7 SET IBALLM(IB176YM,2)=$EXTRACT(IBALLM(IB176YM,1),1,5)
+8 SET IBALLM(IB176YM,0)=IBALLM(IB176YM,2)_"01"
SET IBALLM=$EXTRACT(IBALLM(IB176YM,1),6,7)
+9 IF +$EXTRACT(IB176YM,4,5)=12
SET IB176YM=$EXTRACT(IB176YM,1,3)+1
SET IB176YM=IB176YM_"01"
QUIT
+10 SET IB176YM=IB176YM+1
End DoDot:1
+11 QUIT
+12 ;
KILLXTMP ;
+1 KILL ^XTMP("IBAEC-P176")
+2 QUIT
+3 ;
+4 ;IBDFN - ien of #2
+5 ;IBYM - year_month in yyymm format
CHKXTMP(IBDFN,IBYM) ;check if ^XTMP for the patient and month is exist
+1 QUIT $DATA(^XTMP("IBAEC-P176",IBDFN,IBYM))>0
+2 ;
+3 ;IBDFN - ien of #2
+4 ;IBYM - year_month in yyymm format
UPDXTMP(IBDFN,IBYM) ;update XTMP with new info
+1 NEW IBDT
SET IBDT=$$TODAY^IBAECN1()
+2 SET ^XTMP("IBAEC-P176",0)=$$CHNGDATE^IBAECU4(IBDT,30)_"^"_IBDT_"^1st LTC copay calculation"
+3 SET ^XTMP("IBAEC-P176",+IBDFN,IBYM)=""
+4 QUIT
+5 ;
+6 ;IBDFN - ien of #2
DELXTMP(IBDFN) ;Kills ^XTMP node for the patient.
+1 KILL ^XTMP("IBAEC-P176",+IBDFN)
+2 QUIT
+3 ;
