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