IBAECM1 ;WOIFO/SS-LTC PHASE 2 MONTHLY JOB ; 20-FEB-02
;;2.0;INTEGRATED BILLING;**176**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;Input: IBMDS1 - array with month info
;IBMDS1 (0)-first day of the month
;IBMDS1 (1)-last day of the month
;IBMDS1 (2)-yyymm in Fileman format (like 30201 - for Jan 2002)
MJT ;entry for Monthly Calculation Process
;(array IBMDS1 must be specified outside!)
Q:'$D(IBMDS1)
;------ variables
N IBCLKAD1 ; variable to return back from PROCPAT info for clock adjustment
N IBDFN
N IBCLKIE1
N IBONCE ;to detect "more than 1 active clock" case for the patient
N IBCLKDAT ;clock data
N IBSTRTD ;EFFECTIVE DATE
S IBSTRTD=$$BILDATE^IBAECN1()
K ^TMP($J,"IBMJERR")
K ^TMP($J,"IBMJINP")
K ^TMP($J,"IBMJOUT")
;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="",IBONCE=0
. 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 previous month
. . ; i.e. this patient has been already processed. Probably when MJ already has been run and then crushed.
. . ;in such cases NJ runs MJ again next day. SO we don't need to charge the patient again.
. . Q:$P(IBCLKDAT,"^",7)>IBMDS1(1)
. . ; if error save it in ^TMP for further e-mail
. . I IBONCE>0 D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBCLKIE1),"Clocks","Patient has more than one OPEN LTC clocks") Q
. . S IBONCE=1
. . S IBCLKAD1=""
. . ;process the patient
. . I $$PROCPAT^IBAECM2(.IBMDS1,IBDFN1,IBSTRTD,IBCLKIE1)=-1 D
. . . D ERRLOG^IBAECU5(+$G(IBDFN1),+$G(IBCLKIE1),"Charge","Error with LTC clock creation occured during calculation, no proper charges have been created") Q
;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
Q
;
;-----
;180 clock days issue
;calculates proper LTC Monthly Copay Amount:
;IBDFN2 -patient's ien in file #2
;IBINF - admission info
;IBENROL - enrollment info (returned by $$COPAY^EASECCAL)
;IBADMLEN - admission lenght
;returns:
; 0- if patient does not have >180 days of continious LTC
; 1- if patient has >180 days of continious LTC (only stay days are counted)
;IBAMOUNT - returns back proper amount
MONTHMAX(IBDFN2,IBINF,IBENROL,IBADMLEN,IBAMOUNT) ;
N IB180DS
S IBAMOUNT=+$P(IBENROL,"^",3) ;by default is "<=180 days" amount
;if less or equal 180 days -quit
I IBADMLEN=1 Q 0 ;>>QUIT
; how many stay days in this admission:
S IB180DS=$$STAYDS^IBAECU2(IBINF(1),IBINF(3),IBINF,IBINF(2))
;if stay days <= 180 then quit & return
I IB180DS<181 Q 0 ;>>QUIT
;if stay days > 180 then we have to check if any treating
;specialty change breaks this 181+ continious period
; Analyse all this admission period to find out any 180 days clock
; breaks related to changing specialty.
;MORE180(IBDFN,IBADM,IBLSTDAY,IBDISCH)
I $$MORE180^IBAECU2(IBDFN2,IBINF,IBINF(3),IBINF(2))=0 Q 0 ;>>QUIT
; If there is no any non-LTC specialties during 180 days of stay before
; discharge or last day of the processing month and stay days >180 :
S IBAMOUNT=+$P(IBENROL,"^",4) ;amount for 181+ days
Q 1
;---
;finds the length of active LTC admission that started before IBFRST
;IBFRST - first date of the date frame
;IBLAST - last date of the date frame
;IBDFN - ien of the patient in #2
;IBLBL - ^TMP identifier
;returns number of days if found such admission
;returns 1 if not found
;.IBINF returns:
;IBINF - #405 ien
;IBINF(0) total days of admission
;IBINF(1) first day of admission
;IBINF(2) discharge date of admission
;IBINF(3) last_date_of_admission or last date of
; this period if vet is not discharged yet
DAYS180(IBFRST,IBLAST,IBDFN,IBLBL,IBINF) ;
N IBV1,IBV2,IBFL,IB405
S IBFL=0
S IB405=0
F S IB405=+$O(^TMP($J,IBLBL,IBDFN,IB405)) Q:IB405=0!(IBFL>0) D
. ;quit if admission started this month
. I +$G(^TMP($J,IBLBL,IBDFN,IB405))'<IBFRST Q
. S IBV1=+$O(^TMP($J,IBLBL,IBDFN,IB405,"SD",0))
. ;if found stay day in the first day and this is LTC service then quit
. I IBV1=IBFRST,$P($G(^TMP($J,IBLBL,IBDFN,IB405,"SD",IBV1)),"^",1)="L" S IBFL=IB405 Q
. S IBV1=+$O(^TMP($J,IBLBL,IBDFN,IB405,"LD",0))
. ;if found leave day in the first day and this is LTC service then quit
. I IBV1=IBFRST,$P($G(^TMP($J,IBLBL,IBDFN,IB405,"LD",IBV1)),"^",1)="L" S IBFL=IB405 Q
I IBFL=0 Q 1 ;not found >>QUIT
;if found
S IBV1=$G(^TMP($J,IBLBL,IBDFN,IBFL))
Q:IBV1="" 1 ;error >>QUIT
S IBINF=IBFL ;ien of #405
S IBINF(0)=+$P(IBV1,"^",6) ;total number of inpatient days
I IBINF(0)>0 D Q IBINF(0) ;found >>QUIT
. ;first day of admission
. S IBINF(1)=+$P(IBV1,"^",1)
. ;discharge date of admission
. S IBINF(2)=+$P(IBV1,"^",2)
. ;last_date_of_admission
. S IBINF(3)=+$P(IBV1,"^",3)
. ;if no discharge then last day is IBLAST
. ;otherwise last day = discharge
. S:IBINF(2)=0 IBINF(3)=IBLAST
Q 1
;
;clean all ^TMP related to the patient
CLEAN(IBDFN2) ;
K ^TMP($J,"IBLTCARR",IBDFN2)
K ^TMP($J,"IBMJINP",IBDFN2)
K ^TMP($J,"IBMJOUT",IBDFN2)
;K ^TMP($J,"IB180",IBDFN1)
Q
;--
;Returns the last day (in FM format) of the previous month
PREVMNTH() ;
N X,X1,X2
D NOW^%DTC
S X1=$E(X,1,5)_"01"
S X2=-1
D C^%DTC
Q X
;
;
;runs for each day of the month for the patient
;checks LTC clock and makes necessary adjustments
;Input:
;IBCLIEN Ien of #351.81
;IBDT Date in FM format
;IBDFN Patient's ien of #2
;Output:
;returns current IEN or new one if #351.81 entry has been created
;returns 0 if fatal error
CH21BFR(IBCLIEN,IBDT,IBDFN) ;
N IBCLDATA,IB1,IB2,IBLCKER
S IBLCKER=0
S IBCLIEN=+IBCLIEN
S IB1=IBCLIEN
S IBCLDATA=$G(^IBA(351.81,IBCLIEN,0))
I IBCLDATA=""!($P(IBCLDATA,"^",1)="")!($P(IBCLDATA,"^",2)="")!($P(IBCLDATA,"^",3)="") D Q 0
. D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBCLIEN),"Clocks","0-node data corrupted in LTC clock")
; Check clock expiration date
; if there is no exp date then set it
I $P(IBCLDATA,"^",4)="" D
. S IB2=+$P(IBCLDATA,"^",3)
. S:IB2=0 IB2=IBDT
. L +^IBA(351.81,0):10 I '$T D S IBLCKER=1 Q ;quit
. . D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBCLIEN),"Clocks","Lock error: clock was not reset")
. D RESET21^IBAECU4(IBCLIEN,IB2,IBDFN) ;set EXPIRATION DATE
. D FIX21CLK^IBAECU4(IBCLIEN)
. D CLKSTAMP^IBAECU4(IBCLIEN,IBDFN)
. L -^IBA(351.81,0)
. S IBCLDATA=$G(^IBA(351.81,IBCLIEN,0))
Q:IBLCKER=1 IBCLIEN
;if clock expired close existent and set new one
I IBDT>$P(IBCLDATA,"^",4) D
. L +^IBA(351.81,0):10 I '$T D Q ;quit
. . D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBCLIEN),"Clocks","Lock error: clock was not closed")
. D CLOSECLK^IBAECU4(IBCLIEN,IBDFN)
. D CLKSTAMP^IBAECU4(IBCLIEN,IBDFN)
. S IBCLIEN=$$NEWCLK^IBAECU4(IBDFN,IBDT)
. I IBCLIEN=0 D L -^IBA(351.81,0) Q
. . D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBCLIEN),"Clocks","Lock error: clock was not created")
. D RESET21^IBAECU4(IBCLIEN,IBDT,IBDFN)
. D FIX21CLK^IBAECU4(IBCLIEN)
. D CLKSTAMP^IBAECU4(IBCLIEN,IBDFN)
. L -^IBA(351.81,0)
Q IBCLIEN
;add new free day to 21 clock
;Input:
;IBCLIEN Ien of #351.81
;IBDT Date in FM format
;IBDFN Patient's ien of #2
ADD21DAY(IBCLIEN,IBDT,IBDFN) ;
N IBCLDATA,IB1,IB2
S IBCLIEN=+IBCLIEN
S IB1=IBCLIEN
S IBCLDATA=$G(^IBA(351.81,IBCLIEN,0))
I IBCLDATA="" D Q
. D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBCLIEN),"Clocks","0-node data corrupted in LTC clock")
;if clock is not expired & still DAYS REMAINING>0 - do not charge,
;add exempt day to clock
I $P(IBCLDATA,"^",4)="" D RESET21^IBAECU4(IBCLIEN,IBDT,IBDFN),FIX21CLK^IBAECU4(IBCLIEN)
I +$P(IBCLDATA,"^",6)=21,+$P(IBCLDATA,"^",3)'=IBDT D RESET21^IBAECU4(IBCLIEN,IBDT,IBDFN) ;if begin date'=1st free day, then fix begin & expir. dates
I $P(IBCLDATA,"^",4)'<IBDT,$P(IBCLDATA,"^",6)>0 D
. L +^IBA(351.81,0):10 I '$T D Q ;quit
. . D ERRLOG^IBAECU5(+$G(IBDFN),+$G(IBCLIEN),"Clocks","Lock error: new free day not added")
. D ADDEXDAY^IBAECU4(IBCLIEN,IBDT,IBDFN)
. D CLKSTAMP^IBAECU4(IBCLIEN,IBDFN)
. L -^IBA(351.81,0)
Q
;
;entry point ONLY for testing purposes:
;prepare date range for current month
;dates,days for processing month
TESTMJ ;
D NOW^%DTC
;if you want to test MJ for specific month then
;set X to specific date and run TESTX
TESTX ;
S $P(^IBE(350.9,1,0),"^",16)=0
THEMONTH ;
S IBMDS1(1)=$$LASTDT^IBAECU(X)
S IBMDS1(2)=$E(IBMDS1(1),1,5)
S IBMDS1(0)=IBMDS1(2)_"01",IBMDS1=$E(IBMDS1(1),6,7)
;run MJ with date range specified outside (above) using MJT entry point
D MJT
;set LAST LTC COMPLETION DATE to 0 to allow event handlers to update LTC clock file;
S $P(^IBE(350.9,1,0),"^",16)=0
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAECM1 9311 printed Dec 13, 2024@02:06 Page 2
IBAECM1 ;WOIFO/SS-LTC PHASE 2 MONTHLY JOB ; 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 ;
+4 ;Input: IBMDS1 - array with month info
+5 ;IBMDS1 (0)-first day of the month
+6 ;IBMDS1 (1)-last day of the month
+7 ;IBMDS1 (2)-yyymm in Fileman format (like 30201 - for Jan 2002)
MJT ;entry for Monthly Calculation Process
+1 ;(array IBMDS1 must be specified outside!)
+2 if '$DATA(IBMDS1)
QUIT
+3 ;------ variables
+4 ; variable to return back from PROCPAT info for clock adjustment
NEW IBCLKAD1
+5 NEW IBDFN
+6 NEW IBCLKIE1
+7 ;to detect "more than 1 active clock" case for the patient
NEW IBONCE
+8 ;clock data
NEW IBCLKDAT
+9 ;EFFECTIVE DATE
NEW IBSTRTD
+10 SET IBSTRTD=$$BILDATE^IBAECN1()
+11 KILL ^TMP($JOB,"IBMJERR")
+12 KILL ^TMP($JOB,"IBMJINP")
+13 KILL ^TMP($JOB,"IBMJOUT")
+14 ;go thru all patients in #351.81
+15 SET IBDFN1=0
+16 ;for each patient in file 351.81
+17 FOR
SET IBDFN1=$ORDER(^IBA(351.81,"C",IBDFN1))
if +IBDFN1=0
QUIT
Begin DoDot:1
+18 SET IBCLKIE1=0
SET IBERR=""
SET IBONCE=0
+19 FOR
SET IBCLKIE1=+$ORDER(^IBA(351.81,"C",IBDFN1,IBCLKIE1))
if +IBCLKIE1=0
QUIT
Begin DoDot:2
+20 SET IBCLKDAT=^IBA(351.81,IBCLKIE1,0)
+21 ; quit if STATUS'=OPEN
+22 if $PIECE(IBCLKDAT,"^",5)'=1
QUIT
+23 ; quit if CURRENT EVENTS DATE="" i.e. no LTC events happend
+24 ; this month for the patient
+25 if $PIECE(IBCLKDAT,"^",7)=""
QUIT
+26 ; quit if CURRENT EVENTS DATE>last day of previous month
+27 ; i.e. this patient has been already processed. Probably when MJ already has been run and then crushed.
+28 ;in such cases NJ runs MJ again next day. SO we don't need to charge the patient again.
+29 if $PIECE(IBCLKDAT,"^",7)>IBMDS1(1)
QUIT
+30 ; if error save it in ^TMP for further e-mail
+31 IF IBONCE>0
DO ERRLOG^IBAECU5(+$GET(IBDFN1),+$GET(IBCLKIE1),"Clocks","Patient has more than one OPEN LTC clocks")
QUIT
+32 SET IBONCE=1
+33 SET IBCLKAD1=""
+34 ;process the patient
+35 IF $$PROCPAT^IBAECM2(.IBMDS1,IBDFN1,IBSTRTD,IBCLKIE1)=-1
Begin DoDot:3
+36 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:3
End DoDot:2
End DoDot:1
+37 ;send all errors to user group
+38 ;send all errors
DO SENDERR^IBAECU5
+39 ;if we reach this place that means that we processed everybody
+40 ;and we stamp the date into IB SITE PARAMETERS
+41 SET $PIECE(^IBE(350.9,1,0),"^",16)=$$TODAY^IBAECN1()
+42 ;if Nightly Job founds that date $P(^IBE(350.9,1,0),"^",16)
+43 ;is less that begining of current month than NJ runs MJ again and MJ will
+44 ;process a rest patients
+45 QUIT
+46 ;
+47 ;-----
+48 ;180 clock days issue
+49 ;calculates proper LTC Monthly Copay Amount:
+50 ;IBDFN2 -patient's ien in file #2
+51 ;IBINF - admission info
+52 ;IBENROL - enrollment info (returned by $$COPAY^EASECCAL)
+53 ;IBADMLEN - admission lenght
+54 ;returns:
+55 ; 0- if patient does not have >180 days of continious LTC
+56 ; 1- if patient has >180 days of continious LTC (only stay days are counted)
+57 ;IBAMOUNT - returns back proper amount
MONTHMAX(IBDFN2,IBINF,IBENROL,IBADMLEN,IBAMOUNT) ;
+1 NEW IB180DS
+2 ;by default is "<=180 days" amount
SET IBAMOUNT=+$PIECE(IBENROL,"^",3)
+3 ;if less or equal 180 days -quit
+4 ;>>QUIT
IF IBADMLEN=1
QUIT 0
+5 ; how many stay days in this admission:
+6 SET IB180DS=$$STAYDS^IBAECU2(IBINF(1),IBINF(3),IBINF,IBINF(2))
+7 ;if stay days <= 180 then quit & return
+8 ;>>QUIT
IF IB180DS<181
QUIT 0
+9 ;if stay days > 180 then we have to check if any treating
+10 ;specialty change breaks this 181+ continious period
+11 ; Analyse all this admission period to find out any 180 days clock
+12 ; breaks related to changing specialty.
+13 ;MORE180(IBDFN,IBADM,IBLSTDAY,IBDISCH)
+14 ;>>QUIT
IF $$MORE180^IBAECU2(IBDFN2,IBINF,IBINF(3),IBINF(2))=0
QUIT 0
+15 ; If there is no any non-LTC specialties during 180 days of stay before
+16 ; discharge or last day of the processing month and stay days >180 :
+17 ;amount for 181+ days
SET IBAMOUNT=+$PIECE(IBENROL,"^",4)
+18 QUIT 1
+19 ;---
+20 ;finds the length of active LTC admission that started before IBFRST
+21 ;IBFRST - first date of the date frame
+22 ;IBLAST - last date of the date frame
+23 ;IBDFN - ien of the patient in #2
+24 ;IBLBL - ^TMP identifier
+25 ;returns number of days if found such admission
+26 ;returns 1 if not found
+27 ;.IBINF returns:
+28 ;IBINF - #405 ien
+29 ;IBINF(0) total days of admission
+30 ;IBINF(1) first day of admission
+31 ;IBINF(2) discharge date of admission
+32 ;IBINF(3) last_date_of_admission or last date of
+33 ; this period if vet is not discharged yet
DAYS180(IBFRST,IBLAST,IBDFN,IBLBL,IBINF) ;
+1 NEW IBV1,IBV2,IBFL,IB405
+2 SET IBFL=0
+3 SET IB405=0
+4 FOR
SET IB405=+$ORDER(^TMP($JOB,IBLBL,IBDFN,IB405))
if IB405=0!(IBFL>0)
QUIT
Begin DoDot:1
+5 ;quit if admission started this month
+6 IF +$GET(^TMP($JOB,IBLBL,IBDFN,IB405))'<IBFRST
QUIT
+7 SET IBV1=+$ORDER(^TMP($JOB,IBLBL,IBDFN,IB405,"SD",0))
+8 ;if found stay day in the first day and this is LTC service then quit
+9 IF IBV1=IBFRST
IF $PIECE($GET(^TMP($JOB,IBLBL,IBDFN,IB405,"SD",IBV1)),"^",1)="L"
SET IBFL=IB405
QUIT
+10 SET IBV1=+$ORDER(^TMP($JOB,IBLBL,IBDFN,IB405,"LD",0))
+11 ;if found leave day in the first day and this is LTC service then quit
+12 IF IBV1=IBFRST
IF $PIECE($GET(^TMP($JOB,IBLBL,IBDFN,IB405,"LD",IBV1)),"^",1)="L"
SET IBFL=IB405
QUIT
End DoDot:1
+13 ;not found >>QUIT
IF IBFL=0
QUIT 1
+14 ;if found
+15 SET IBV1=$GET(^TMP($JOB,IBLBL,IBDFN,IBFL))
+16 ;error >>QUIT
if IBV1=""
QUIT 1
+17 ;ien of #405
SET IBINF=IBFL
+18 ;total number of inpatient days
SET IBINF(0)=+$PIECE(IBV1,"^",6)
+19 ;found >>QUIT
IF IBINF(0)>0
Begin DoDot:1
+20 ;first day of admission
+21 SET IBINF(1)=+$PIECE(IBV1,"^",1)
+22 ;discharge date of admission
+23 SET IBINF(2)=+$PIECE(IBV1,"^",2)
+24 ;last_date_of_admission
+25 SET IBINF(3)=+$PIECE(IBV1,"^",3)
+26 ;if no discharge then last day is IBLAST
+27 ;otherwise last day = discharge
+28 if IBINF(2)=0
SET IBINF(3)=IBLAST
End DoDot:1
QUIT IBINF(0)
+29 QUIT 1
+30 ;
+31 ;clean all ^TMP related to the patient
CLEAN(IBDFN2) ;
+1 KILL ^TMP($JOB,"IBLTCARR",IBDFN2)
+2 KILL ^TMP($JOB,"IBMJINP",IBDFN2)
+3 KILL ^TMP($JOB,"IBMJOUT",IBDFN2)
+4 ;K ^TMP($J,"IB180",IBDFN1)
+5 QUIT
+6 ;--
+7 ;Returns the last day (in FM format) of the previous month
PREVMNTH() ;
+1 NEW X,X1,X2
+2 DO NOW^%DTC
+3 SET X1=$EXTRACT(X,1,5)_"01"
+4 SET X2=-1
+5 DO C^%DTC
+6 QUIT X
+7 ;
+8 ;
+9 ;runs for each day of the month for the patient
+10 ;checks LTC clock and makes necessary adjustments
+11 ;Input:
+12 ;IBCLIEN Ien of #351.81
+13 ;IBDT Date in FM format
+14 ;IBDFN Patient's ien of #2
+15 ;Output:
+16 ;returns current IEN or new one if #351.81 entry has been created
+17 ;returns 0 if fatal error
CH21BFR(IBCLIEN,IBDT,IBDFN) ;
+1 NEW IBCLDATA,IB1,IB2,IBLCKER
+2 SET IBLCKER=0
+3 SET IBCLIEN=+IBCLIEN
+4 SET IB1=IBCLIEN
+5 SET IBCLDATA=$GET(^IBA(351.81,IBCLIEN,0))
+6 IF IBCLDATA=""!($PIECE(IBCLDATA,"^",1)="")!($PIECE(IBCLDATA,"^",2)="")!($PIECE(IBCLDATA,"^",3)="")
Begin DoDot:1
+7 DO ERRLOG^IBAECU5(+$GET(IBDFN),+$GET(IBCLIEN),"Clocks","0-node data corrupted in LTC clock")
End DoDot:1
QUIT 0
+8 ; Check clock expiration date
+9 ; if there is no exp date then set it
+10 IF $PIECE(IBCLDATA,"^",4)=""
Begin DoDot:1
+11 SET IB2=+$PIECE(IBCLDATA,"^",3)
+12 if IB2=0
SET IB2=IBDT
+13 ;quit
LOCK +^IBA(351.81,0):10
IF '$TEST
Begin DoDot:2
+14 DO ERRLOG^IBAECU5(+$GET(IBDFN),+$GET(IBCLIEN),"Clocks","Lock error: clock was not reset")
End DoDot:2
SET IBLCKER=1
QUIT
+15 ;set EXPIRATION DATE
DO RESET21^IBAECU4(IBCLIEN,IB2,IBDFN)
+16 DO FIX21CLK^IBAECU4(IBCLIEN)
+17 DO CLKSTAMP^IBAECU4(IBCLIEN,IBDFN)
+18 LOCK -^IBA(351.81,0)
+19 SET IBCLDATA=$GET(^IBA(351.81,IBCLIEN,0))
End DoDot:1
+20 if IBLCKER=1
QUIT IBCLIEN
+21 ;if clock expired close existent and set new one
+22 IF IBDT>$PIECE(IBCLDATA,"^",4)
Begin DoDot:1
+23 ;quit
LOCK +^IBA(351.81,0):10
IF '$TEST
Begin DoDot:2
+24 DO ERRLOG^IBAECU5(+$GET(IBDFN),+$GET(IBCLIEN),"Clocks","Lock error: clock was not closed")
End DoDot:2
QUIT
+25 DO CLOSECLK^IBAECU4(IBCLIEN,IBDFN)
+26 DO CLKSTAMP^IBAECU4(IBCLIEN,IBDFN)
+27 SET IBCLIEN=$$NEWCLK^IBAECU4(IBDFN,IBDT)
+28 IF IBCLIEN=0
Begin DoDot:2
+29 DO ERRLOG^IBAECU5(+$GET(IBDFN),+$GET(IBCLIEN),"Clocks","Lock error: clock was not created")
End DoDot:2
LOCK -^IBA(351.81,0)
QUIT
+30 DO RESET21^IBAECU4(IBCLIEN,IBDT,IBDFN)
+31 DO FIX21CLK^IBAECU4(IBCLIEN)
+32 DO CLKSTAMP^IBAECU4(IBCLIEN,IBDFN)
+33 LOCK -^IBA(351.81,0)
End DoDot:1
+34 QUIT IBCLIEN
+35 ;add new free day to 21 clock
+36 ;Input:
+37 ;IBCLIEN Ien of #351.81
+38 ;IBDT Date in FM format
+39 ;IBDFN Patient's ien of #2
ADD21DAY(IBCLIEN,IBDT,IBDFN) ;
+1 NEW IBCLDATA,IB1,IB2
+2 SET IBCLIEN=+IBCLIEN
+3 SET IB1=IBCLIEN
+4 SET IBCLDATA=$GET(^IBA(351.81,IBCLIEN,0))
+5 IF IBCLDATA=""
Begin DoDot:1
+6 DO ERRLOG^IBAECU5(+$GET(IBDFN),+$GET(IBCLIEN),"Clocks","0-node data corrupted in LTC clock")
End DoDot:1
QUIT
+7 ;if clock is not expired & still DAYS REMAINING>0 - do not charge,
+8 ;add exempt day to clock
+9 IF $PIECE(IBCLDATA,"^",4)=""
DO RESET21^IBAECU4(IBCLIEN,IBDT,IBDFN)
DO FIX21CLK^IBAECU4(IBCLIEN)
+10 ;if begin date'=1st free day, then fix begin & expir. dates
IF +$PIECE(IBCLDATA,"^",6)=21
IF +$PIECE(IBCLDATA,"^",3)'=IBDT
DO RESET21^IBAECU4(IBCLIEN,IBDT,IBDFN)
+11 IF $PIECE(IBCLDATA,"^",4)'<IBDT
IF $PIECE(IBCLDATA,"^",6)>0
Begin DoDot:1
+12 ;quit
LOCK +^IBA(351.81,0):10
IF '$TEST
Begin DoDot:2
+13 DO ERRLOG^IBAECU5(+$GET(IBDFN),+$GET(IBCLIEN),"Clocks","Lock error: new free day not added")
End DoDot:2
QUIT
+14 DO ADDEXDAY^IBAECU4(IBCLIEN,IBDT,IBDFN)
+15 DO CLKSTAMP^IBAECU4(IBCLIEN,IBDFN)
+16 LOCK -^IBA(351.81,0)
End DoDot:1
+17 QUIT
+18 ;
+19 ;entry point ONLY for testing purposes:
+20 ;prepare date range for current month
+21 ;dates,days for processing month
TESTMJ ;
+1 DO NOW^%DTC
+2 ;if you want to test MJ for specific month then
+3 ;set X to specific date and run TESTX
TESTX ;
+1 SET $PIECE(^IBE(350.9,1,0),"^",16)=0
THEMONTH ;
+1 SET IBMDS1(1)=$$LASTDT^IBAECU(X)
+2 SET IBMDS1(2)=$EXTRACT(IBMDS1(1),1,5)
+3 SET IBMDS1(0)=IBMDS1(2)_"01"
SET IBMDS1=$EXTRACT(IBMDS1(1),6,7)
+4 ;run MJ with date range specified outside (above) using MJT entry point
+5 DO MJT
+6 ;set LAST LTC COMPLETION DATE to 0 to allow event handlers to update LTC clock file;
+7 SET $PIECE(^IBE(350.9,1,0),"^",16)=0
+8 QUIT
+9 ;
