- 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 Feb 18, 2025@23:32:27 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 ;