IBAECM2 ;WOIFO/SS-LTC PHASE 2 MONTHLY JOB ; 20-FEB-02
;;2.0;INTEGRATED BILLING;**176,198,188**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;
;Copay calculation for the patient
;Input:
;IBMDS - days array
; IBMDS(0)-first day of the month
; IBMDS(1)-last day of the month
; IBMDS(2)-yyymm (like 30201 - for Jan 2002)
;IBDFN - dfn
;IBSTART - date to start calclation from,
; normally it is the first day of the month,
; but for very first time it will be the effective date
;IBCLKIEN - 351.81 ien
;returns 0 if no charges for any reason
;otherwise returns 1
PROCPAT(IBMDS,IBDFN,IBSTART,IBCLKIEN) ;
;IBCHRG - charge array, is used for SEND2AR, contains all charges for
;the patient for this month
;one day may contain only one rate (charge), that prevents duplications
; "A",IBDAY,"R"=rate^ien_of_#350.1(i.e.IB action type)
; "A",IBDAY,"T"=type or care^source^date
;where
; outpatient:
; type or care - 1
; source - ien of #409.68
; date - date of service
; inpatient:
; type or care - 2
; source - ien of #405
; date - date of admission
N IBCHRG
N IBDAY,IBDATE,IBINPAT,IBOUTPAT,IBRET,IBCMCA
N IBINPINF,IBADM1,IBVISIT,IBCOMPEN,IBV1,IBV2
N IBLDINP,IB40968,IBFDAY
S IBCHRG=0,IBLDINP="^"
D CLEAN^IBAECM1(IBDFN)
; determine first day (IBFDAY) of FOR cycle:
S IBFDAY=1 ;default
S IBSTART=+$G(IBSTART)
;if effective date is greater than the last day of this month, then do nothing
Q:IBSTART>IBMDS(1) IBCHRG
;if effective date is in current month, then cycle starts from
;this day of the month
S IBFDAY=+$E(IBSTART,6,7)
;if effective date is less than this month, then starts from
;the first day of the month
S:IBSTART<IBMDS(0) IBFDAY=1
;----
; use LOS=1 to get patient status
S IBRET=+$$LTCST^IBAECU(IBDFN,IBMDS(1),1)
;** EXEMPTION from co-pay **
I IBRET=1 Q IBCHRG ;>>QUIT
;
;get all data about all inpatient episodes
;IBINPAT'=0 - there are inpatient episodes
S IBINPAT=$$INPINFO^IBAECU2(IBMDS(0),IBMDS(1),IBDFN,"IBMJINP",1)
;get all data about all outpatient episodes
;IBOUTPAT'=0 - there are outpatient episodes
S IBOUTPAT=$$OUTPINFO^IBAECU3(IBMDS(0),IBMDS(1),IBDFN,"IBMJOUT")
;no 1010EC - send e-mail and quit
I IBRET=0 D Q IBCHRG ;>>QUIT
. S IBV1=$O(^TMP($J,"IBMJINP",IBDFN,0))
. I +IBV1>0 S IBV1=+$G(^TMP($J,"IBMJINP",IBDFN,IBV1))
. I +IBV1=0 S IBV1=$O(^TMP($J,"IBMJOUT",IBDFN,IBV1))
. I +IBV1=0 S IBV1=IBMDS(0)
. ; changed in 188 to eliminate some messages when nothing there
. I IBINPAT'=0!(IBOUTPAT'=0) D MESS10EC^IBAECU5(IBDFN,IBV1)
. D CLEAN^IBAECM1(IBDFN)
. ; update or clean out current events date
. S DR=".07///"_$S($D(^DPT(IBDFN,.1)):$E(DT,1,5)_"01",1:"@")
. S DIE="^IBA(351.81,",DA=IBCLKIEN D ^DIE
;
; if no inpatient, no outpatient episodes and still 21 free days
; remain - someone cancelled episodes and we cancel the clock
I IBINPAT=0,IBOUTPAT=0,$P($G(^IBA(351.81,IBCLKIEN,0)),"^",6)=21 D Q IBCHRG ;>>QUIT
. D CLCKADJ^IBAECU4("C",IBCLKIEN,IBDFN,"^",IBMDS(1))
. S IBCHRG("A")=0 ; no charges
. D CLEAN^IBAECM1(IBDFN)
;
; check correctness of 21 days clock if error then fix it and notify the users
S IBV2=$$CHKDSERR^IBAECU4(IBCLKIEN,IBDFN)
I IBV2<0 D FIX21CLK^IBAECU4(IBCLKIEN)
; ==============Go thru each day =============================
F IBDAY=IBFDAY:1:IBMDS Q:IBCLKIEN=0 S IBDATE=$$MKDATE^IBAECU4(IBMDS(2),IBDAY) D
. ;***** Gathering all necessary info ******
. ; C&P status
. S IBCOMPEN=$$ISCOMPEN^IBAECU5(IBDFN,IBDATE)
. ; INPATIENT episodes
. S IBADM1=0 ;adm ien
. S IBINPINF="" K IBINPINF("M"),IBINPINF("L")
. ; is any inpatient LTC this day?
. S IBINPINF=$$ISINPAT^IBAECU2(IBDFN,IBDATE,"IBMJINP",.IBINPINF)
. ;
. ; if the patient has inpatient service in the last day of the
. ; processed month, then "CURRENT EVENTS DATE" in LTC clock (#351.81)
. ; must be set to the 1st day of the following month to indicate that
. ; the patient must be checked for LTC copay by MJ next month.
. ; Thus if so we set IBLDINP to IBINPINF (calcualted for the last day
. ; of the processed month)(see CLCKADJ)
. I IBMDS(1)=IBDATE S IBLDINP=IBINPINF
. ; OUTPATIENT episodes
. S IB40968=0
. S IBVISIT="" K IBVISIT("M"),IBVISIT("L")
. ;is there any outp episode with this day?
. S IBVISIT=$$ISOUTP^IBAECU3(IBDFN,IBDATE,"IBMJOUT",.IBVISIT)
. ; If there is LTC event this day (IBDATE) and if current
. ; CLOCK BEGIN DATE > IBDATE then change it to IBDATE
. ; (& reset its expiration date)
. I +IBVISIT!(+IBINPINF) I $P($G(^IBA(351.81,IBCLKIEN,0)),"^",3)>IBDATE D RESET21^IBAECU4(IBCLKIEN,IBDATE,IBDFN)
. ;*****************************************
. ; check 21 days clock file
. ; check expiration date,etc of 21 clock
. S IBCLKIEN=$$CH21BFR^IBAECM1(IBCLKIEN,IBDATE,IBDFN) ;
. I IBCLKIEN=0 Q ;ERROR - new entry in #351.81 was not created - quit !
. ;
. ; 1. LTC inpatient in bed - ALWAYS charge him
. S IBADM1=+$O(IBINPINF("L","SD",0))
. I IBADM1>0 D Q ;>>>>QUIT - GO to NEXT DAY
. . ;look for and cancel Means Test Outpatient charges for this date
. . D CHKMTOUT^IBAECU3(IBDFN,IBDATE,"IBMJOUT")
. . ; check expiration date,etc of 21 clock
. . ; $$EXEMPT21 checks if vet is eligible for 21 clock exemption
. . ; 1 - if exempted, don't charge the patient
. . I $$EXEMPT21^IBAECU4(IBCLKIEN)=1 D Q
. . . ;add new exempt day to LTC clock
. . . D ADD21DAY^IBAECM1(IBCLKIEN,IBDATE,IBDFN)
. . ; otherwise no 21 clock exemption - cretae a charge
. . ;get rate for this treating specialty
. . S IBCHRG("A",IBDAY,"R")=$$GETRATE^IBAECU3(2,+$G(IBINPINF("L","SD",IBADM1)),IBDATE)_"^"_$P($G(IBINPINF("L","SD",IBADM1)),"^",2)
. . S IBCHRG("A",IBDAY,"T")="2^"_IBADM1_"^"_$P($G(IBINPINF("L","SD",IBADM1)),"^",3) ;inpatient
. . S IBCHRG=IBCHRG+1
. ;
. ; 2. MeansTest inpatient in bed or in AA,UA or ASIH
. ; do not charge vet for LTC outpatient visit
. ; - MT inpatient care has precedence on LTC outpatient visit if vet is in bed.
. ; - if MT inpatient in AA,UA,ASIH, the current MT rule don't allow to charge him
. ; for MT outpatien visits in AA,UA&ASIH. It was decided to applied the same rules
. ; to LTC outpatient visits
. S IBADM1=+$O(IBINPINF("M",0))
. Q:IBADM1>0 ;............................>>>>QUIT - GO to NEXT DAY
. ;
. ; 3. LTC inpatient in AA,UA or ASIH
. ; do not charge for any (MT or LTC) outpatient visits (see explanation for 2.)
. S IBADM1=+$O(IBINPINF("L","LD",0))
. I IBADM1>0 D Q ;>>>>QUIT - GO to NEXT DAY
. . ;look for and cancel Means Test Outpatient charges for this date
. . ;(at this point can be only outpatient MT charges,
. . ;because inpatient MT has gone earlier in 2.)
. . D CHKMTOUT^IBAECU3(IBDFN,IBDATE,"IBMJOUT")
. ;
. ; 4. C&P exam
. ; if C&P exam then any outpatient visits are exempted,no charge,goto NEXT DAY
. Q:IBCOMPEN=1 ;............................>>>>QUIT - GO to NEXT DAY
. ;
. ; 5. LTC outpatient visit
. ;check if vet has a LTC outpatient visit
. S IB40968=+$O(IBVISIT("L",0))
. I IB40968>0 D
. . ;look for and cancel Means Test Outpatient charges for this date
. . D CHKMTOUT^IBAECU3(IBDFN,IBDATE,"IBMJOUT")
. . ; $$EXEMPT21 checks if vet is eligible for 21 clock exemption
. . ; 1 - if exempted, don't charge the patient
. . I $$EXEMPT21^IBAECU4(IBCLKIEN)=1 D Q
. . . ;add new exempt day to LTC clock
. . . D ADD21DAY^IBAECM1(IBCLKIEN,IBDATE,IBDFN)
. . ; otherwise no 21 clock exemption - cretae a charge
. . ;get rate for LTC visit on this date
. . S IBCHRG("A",IBDAY,"R")=$$GETRATE^IBAECU3(1,+$G(IBVISIT("L",IB40968)),IBDATE)_"^"_$P($G(IBVISIT("L",IB40968)),"^",2)
. . S IBCHRG("A",IBDAY,"T")="1^"_IB40968_"^"_$$MKDATE^IBAECU4(IBMDS(2),IBDAY) ;outpatient
. . S IBCHRG=IBCHRG+1
. Q
;=============================================================
I IBCLKIEN=0 Q -1 ;error
;return month copay
S IBCMCA=$$CLCK180(IBDFN,$S(IBSTART>IBMDS(0):IBSTART,1:IBMDS(0)),IBMDS(1),"IBMJINP")
; create charges for
; check expiration date,etc of 21 clock
I IBCHRG>0 D SEND2AR^IBAECU5(IBDFN,.IBCHRG,.IBMDS,+IBCMCA)
;clock adjustment
D CLCKADJ^IBAECU4("P",IBCLKIEN,IBDFN,IBLDINP,IBMDS(1))
D CLEAN^IBAECM1(IBDFN)
Q IBCHRG
;
;returns "max_monthly_calculated_copay"^"is_181+_case"
;determine 181+ case (takes care about 30 days "gap" between
;prior 181+ and current admission)
CLCK180(IBDFN,IBBEGDT,IBENDDT,IBLBL) ;
;array for adm info
N IBLNGADM,IBADMINF,IBRET1,IBCMC,IS180CLK,IBFL5,IB30BACK
S IBADMINF="^"
; if we have active admission that started before IBMDS(0) then
; What is the length of this admission?
; we need IBLNGADM to call $$COPAY^EASECCAL; If there is
; no admission started before IBMDS(0) then sets IBLNGADM=1
S IBLNGADM=$$DAYS180^IBAECM1(IBBEGDT,IBENDDT,IBDFN,IBLBL,.IBADMINF)
; if none then check if another admission 30 days before (see SDD)
I IBLNGADM=1 D
. S IBFL5=$$ISLTC^IBAECU5(IBDFN,IBLBL)
. Q:IBFL5=0
. K ^TMP($J,"180DAYS")
. S IB30BACK=$$CHNGDATE^IBAECU4(IBFL5,-30)
. I $$INPINFO^IBAECU2(IB30BACK,IBFL5,IBDFN,"180DAYS",1)=0 Q
. K IBADMINF S IBADMINF="^"
. S IBLNGADM=$$DAYS180^IBAECM1(IB30BACK,IBFL5,IBDFN,"180DAYS",.IBADMINF)
; get patient status
S IBRET1=$$LTCST^IBAECU(IBDFN,IBENDDT,IBLNGADM)
;calculate a proper LTC Monthly Copay Amount and put it in IBCMC
;(max amount patient should pay monthly)
;IS180CLK =1 if patient has >180 days of continious LTC
S IS180CLK=$$MONTHMAX^IBAECM1(IBDFN,.IBADMINF,IBRET1,IBLNGADM,.IBCMC)
K ^TMP($J,"180DAYS")
Q +IBCMC_"^"_IS180CLK
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAECM2 9631 printed Oct 16, 2024@18:06:42 Page 2
IBAECM2 ;WOIFO/SS-LTC PHASE 2 MONTHLY JOB ; 20-FEB-02
+1 ;;2.0;INTEGRATED BILLING;**176,198,188**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;
+5 ;Copay calculation for the patient
+6 ;Input:
+7 ;IBMDS - days array
+8 ; IBMDS(0)-first day of the month
+9 ; IBMDS(1)-last day of the month
+10 ; IBMDS(2)-yyymm (like 30201 - for Jan 2002)
+11 ;IBDFN - dfn
+12 ;IBSTART - date to start calclation from,
+13 ; normally it is the first day of the month,
+14 ; but for very first time it will be the effective date
+15 ;IBCLKIEN - 351.81 ien
+16 ;returns 0 if no charges for any reason
+17 ;otherwise returns 1
PROCPAT(IBMDS,IBDFN,IBSTART,IBCLKIEN) ;
+1 ;IBCHRG - charge array, is used for SEND2AR, contains all charges for
+2 ;the patient for this month
+3 ;one day may contain only one rate (charge), that prevents duplications
+4 ; "A",IBDAY,"R"=rate^ien_of_#350.1(i.e.IB action type)
+5 ; "A",IBDAY,"T"=type or care^source^date
+6 ;where
+7 ; outpatient:
+8 ; type or care - 1
+9 ; source - ien of #409.68
+10 ; date - date of service
+11 ; inpatient:
+12 ; type or care - 2
+13 ; source - ien of #405
+14 ; date - date of admission
+15 NEW IBCHRG
+16 NEW IBDAY,IBDATE,IBINPAT,IBOUTPAT,IBRET,IBCMCA
+17 NEW IBINPINF,IBADM1,IBVISIT,IBCOMPEN,IBV1,IBV2
+18 NEW IBLDINP,IB40968,IBFDAY
+19 SET IBCHRG=0
SET IBLDINP="^"
+20 DO CLEAN^IBAECM1(IBDFN)
+21 ; determine first day (IBFDAY) of FOR cycle:
+22 ;default
SET IBFDAY=1
+23 SET IBSTART=+$GET(IBSTART)
+24 ;if effective date is greater than the last day of this month, then do nothing
+25 if IBSTART>IBMDS(1)
QUIT IBCHRG
+26 ;if effective date is in current month, then cycle starts from
+27 ;this day of the month
+28 SET IBFDAY=+$EXTRACT(IBSTART,6,7)
+29 ;if effective date is less than this month, then starts from
+30 ;the first day of the month
+31 if IBSTART<IBMDS(0)
SET IBFDAY=1
+32 ;----
+33 ; use LOS=1 to get patient status
+34 SET IBRET=+$$LTCST^IBAECU(IBDFN,IBMDS(1),1)
+35 ;** EXEMPTION from co-pay **
+36 ;>>QUIT
IF IBRET=1
QUIT IBCHRG
+37 ;
+38 ;get all data about all inpatient episodes
+39 ;IBINPAT'=0 - there are inpatient episodes
+40 SET IBINPAT=$$INPINFO^IBAECU2(IBMDS(0),IBMDS(1),IBDFN,"IBMJINP",1)
+41 ;get all data about all outpatient episodes
+42 ;IBOUTPAT'=0 - there are outpatient episodes
+43 SET IBOUTPAT=$$OUTPINFO^IBAECU3(IBMDS(0),IBMDS(1),IBDFN,"IBMJOUT")
+44 ;no 1010EC - send e-mail and quit
+45 ;>>QUIT
IF IBRET=0
Begin DoDot:1
+46 SET IBV1=$ORDER(^TMP($JOB,"IBMJINP",IBDFN,0))
+47 IF +IBV1>0
SET IBV1=+$GET(^TMP($JOB,"IBMJINP",IBDFN,IBV1))
+48 IF +IBV1=0
SET IBV1=$ORDER(^TMP($JOB,"IBMJOUT",IBDFN,IBV1))
+49 IF +IBV1=0
SET IBV1=IBMDS(0)
+50 ; changed in 188 to eliminate some messages when nothing there
+51 IF IBINPAT'=0!(IBOUTPAT'=0)
DO MESS10EC^IBAECU5(IBDFN,IBV1)
+52 DO CLEAN^IBAECM1(IBDFN)
+53 ; update or clean out current events date
+54 SET DR=".07///"_$SELECT($DATA(^DPT(IBDFN,.1)):$EXTRACT(DT,1,5)_"01",1:"@")
+55 SET DIE="^IBA(351.81,"
SET DA=IBCLKIEN
DO ^DIE
End DoDot:1
QUIT IBCHRG
+56 ;
+57 ; if no inpatient, no outpatient episodes and still 21 free days
+58 ; remain - someone cancelled episodes and we cancel the clock
+59 ;>>QUIT
IF IBINPAT=0
IF IBOUTPAT=0
IF $PIECE($GET(^IBA(351.81,IBCLKIEN,0)),"^",6)=21
Begin DoDot:1
+60 DO CLCKADJ^IBAECU4("C",IBCLKIEN,IBDFN,"^",IBMDS(1))
+61 ; no charges
SET IBCHRG("A")=0
+62 DO CLEAN^IBAECM1(IBDFN)
End DoDot:1
QUIT IBCHRG
+63 ;
+64 ; check correctness of 21 days clock if error then fix it and notify the users
+65 SET IBV2=$$CHKDSERR^IBAECU4(IBCLKIEN,IBDFN)
+66 IF IBV2<0
DO FIX21CLK^IBAECU4(IBCLKIEN)
+67 ; ==============Go thru each day =============================
+68 FOR IBDAY=IBFDAY:1:IBMDS
if IBCLKIEN=0
QUIT
SET IBDATE=$$MKDATE^IBAECU4(IBMDS(2),IBDAY)
Begin DoDot:1
+69 ;***** Gathering all necessary info ******
+70 ; C&P status
+71 SET IBCOMPEN=$$ISCOMPEN^IBAECU5(IBDFN,IBDATE)
+72 ; INPATIENT episodes
+73 ;adm ien
SET IBADM1=0
+74 SET IBINPINF=""
KILL IBINPINF("M"),IBINPINF("L")
+75 ; is any inpatient LTC this day?
+76 SET IBINPINF=$$ISINPAT^IBAECU2(IBDFN,IBDATE,"IBMJINP",.IBINPINF)
+77 ;
+78 ; if the patient has inpatient service in the last day of the
+79 ; processed month, then "CURRENT EVENTS DATE" in LTC clock (#351.81)
+80 ; must be set to the 1st day of the following month to indicate that
+81 ; the patient must be checked for LTC copay by MJ next month.
+82 ; Thus if so we set IBLDINP to IBINPINF (calcualted for the last day
+83 ; of the processed month)(see CLCKADJ)
+84 IF IBMDS(1)=IBDATE
SET IBLDINP=IBINPINF
+85 ; OUTPATIENT episodes
+86 SET IB40968=0
+87 SET IBVISIT=""
KILL IBVISIT("M"),IBVISIT("L")
+88 ;is there any outp episode with this day?
+89 SET IBVISIT=$$ISOUTP^IBAECU3(IBDFN,IBDATE,"IBMJOUT",.IBVISIT)
+90 ; If there is LTC event this day (IBDATE) and if current
+91 ; CLOCK BEGIN DATE > IBDATE then change it to IBDATE
+92 ; (& reset its expiration date)
+93 IF +IBVISIT!(+IBINPINF)
IF $PIECE($GET(^IBA(351.81,IBCLKIEN,0)),"^",3)>IBDATE
DO RESET21^IBAECU4(IBCLKIEN,IBDATE,IBDFN)
+94 ;*****************************************
+95 ; check 21 days clock file
+96 ; check expiration date,etc of 21 clock
+97 ;
SET IBCLKIEN=$$CH21BFR^IBAECM1(IBCLKIEN,IBDATE,IBDFN)
+98 ;ERROR - new entry in #351.81 was not created - quit !
IF IBCLKIEN=0
QUIT
+99 ;
+100 ; 1. LTC inpatient in bed - ALWAYS charge him
+101 SET IBADM1=+$ORDER(IBINPINF("L","SD",0))
+102 ;>>>>QUIT - GO to NEXT DAY
IF IBADM1>0
Begin DoDot:2
+103 ;look for and cancel Means Test Outpatient charges for this date
+104 DO CHKMTOUT^IBAECU3(IBDFN,IBDATE,"IBMJOUT")
+105 ; check expiration date,etc of 21 clock
+106 ; $$EXEMPT21 checks if vet is eligible for 21 clock exemption
+107 ; 1 - if exempted, don't charge the patient
+108 IF $$EXEMPT21^IBAECU4(IBCLKIEN)=1
Begin DoDot:3
+109 ;add new exempt day to LTC clock
+110 DO ADD21DAY^IBAECM1(IBCLKIEN,IBDATE,IBDFN)
End DoDot:3
QUIT
+111 ; otherwise no 21 clock exemption - cretae a charge
+112 ;get rate for this treating specialty
+113 SET IBCHRG("A",IBDAY,"R")=$$GETRATE^IBAECU3(2,+$GET(IBINPINF("L","SD",IBADM1)),IBDATE)_"^"_$PIECE($GET(IBINPINF("L","SD",IBADM1)),"^",2)
+114 ;inpatient
SET IBCHRG("A",IBDAY,"T")="2^"_IBADM1_"^"_$PIECE($GET(IBINPINF("L","SD",IBADM1)),"^",3)
+115 SET IBCHRG=IBCHRG+1
End DoDot:2
QUIT
+116 ;
+117 ; 2. MeansTest inpatient in bed or in AA,UA or ASIH
+118 ; do not charge vet for LTC outpatient visit
+119 ; - MT inpatient care has precedence on LTC outpatient visit if vet is in bed.
+120 ; - if MT inpatient in AA,UA,ASIH, the current MT rule don't allow to charge him
+121 ; for MT outpatien visits in AA,UA&ASIH. It was decided to applied the same rules
+122 ; to LTC outpatient visits
+123 SET IBADM1=+$ORDER(IBINPINF("M",0))
+124 ;............................>>>>QUIT - GO to NEXT DAY
if IBADM1>0
QUIT
+125 ;
+126 ; 3. LTC inpatient in AA,UA or ASIH
+127 ; do not charge for any (MT or LTC) outpatient visits (see explanation for 2.)
+128 SET IBADM1=+$ORDER(IBINPINF("L","LD",0))
+129 ;>>>>QUIT - GO to NEXT DAY
IF IBADM1>0
Begin DoDot:2
+130 ;look for and cancel Means Test Outpatient charges for this date
+131 ;(at this point can be only outpatient MT charges,
+132 ;because inpatient MT has gone earlier in 2.)
+133 DO CHKMTOUT^IBAECU3(IBDFN,IBDATE,"IBMJOUT")
End DoDot:2
QUIT
+134 ;
+135 ; 4. C&P exam
+136 ; if C&P exam then any outpatient visits are exempted,no charge,goto NEXT DAY
+137 ;............................>>>>QUIT - GO to NEXT DAY
if IBCOMPEN=1
QUIT
+138 ;
+139 ; 5. LTC outpatient visit
+140 ;check if vet has a LTC outpatient visit
+141 SET IB40968=+$ORDER(IBVISIT("L",0))
+142 IF IB40968>0
Begin DoDot:2
+143 ;look for and cancel Means Test Outpatient charges for this date
+144 DO CHKMTOUT^IBAECU3(IBDFN,IBDATE,"IBMJOUT")
+145 ; $$EXEMPT21 checks if vet is eligible for 21 clock exemption
+146 ; 1 - if exempted, don't charge the patient
+147 IF $$EXEMPT21^IBAECU4(IBCLKIEN)=1
Begin DoDot:3
+148 ;add new exempt day to LTC clock
+149 DO ADD21DAY^IBAECM1(IBCLKIEN,IBDATE,IBDFN)
End DoDot:3
QUIT
+150 ; otherwise no 21 clock exemption - cretae a charge
+151 ;get rate for LTC visit on this date
+152 SET IBCHRG("A",IBDAY,"R")=$$GETRATE^IBAECU3(1,+$GET(IBVISIT("L",IB40968)),IBDATE)_"^"_$PIECE($GET(IBVISIT("L",IB40968)),"^",2)
+153 ;outpatient
SET IBCHRG("A",IBDAY,"T")="1^"_IB40968_"^"_$$MKDATE^IBAECU4(IBMDS(2),IBDAY)
+154 SET IBCHRG=IBCHRG+1
End DoDot:2
+155 QUIT
End DoDot:1
+156 ;=============================================================
+157 ;error
IF IBCLKIEN=0
QUIT -1
+158 ;return month copay
+159 SET IBCMCA=$$CLCK180(IBDFN,$SELECT(IBSTART>IBMDS(0):IBSTART,1:IBMDS(0)),IBMDS(1),"IBMJINP")
+160 ; create charges for
+161 ; check expiration date,etc of 21 clock
+162 IF IBCHRG>0
DO SEND2AR^IBAECU5(IBDFN,.IBCHRG,.IBMDS,+IBCMCA)
+163 ;clock adjustment
+164 DO CLCKADJ^IBAECU4("P",IBCLKIEN,IBDFN,IBLDINP,IBMDS(1))
+165 DO CLEAN^IBAECM1(IBDFN)
+166 QUIT IBCHRG
+167 ;
+168 ;returns "max_monthly_calculated_copay"^"is_181+_case"
+169 ;determine 181+ case (takes care about 30 days "gap" between
+170 ;prior 181+ and current admission)
CLCK180(IBDFN,IBBEGDT,IBENDDT,IBLBL) ;
+1 ;array for adm info
+2 NEW IBLNGADM,IBADMINF,IBRET1,IBCMC,IS180CLK,IBFL5,IB30BACK
+3 SET IBADMINF="^"
+4 ; if we have active admission that started before IBMDS(0) then
+5 ; What is the length of this admission?
+6 ; we need IBLNGADM to call $$COPAY^EASECCAL; If there is
+7 ; no admission started before IBMDS(0) then sets IBLNGADM=1
+8 SET IBLNGADM=$$DAYS180^IBAECM1(IBBEGDT,IBENDDT,IBDFN,IBLBL,.IBADMINF)
+9 ; if none then check if another admission 30 days before (see SDD)
+10 IF IBLNGADM=1
Begin DoDot:1
+11 SET IBFL5=$$ISLTC^IBAECU5(IBDFN,IBLBL)
+12 if IBFL5=0
QUIT
+13 KILL ^TMP($JOB,"180DAYS")
+14 SET IB30BACK=$$CHNGDATE^IBAECU4(IBFL5,-30)
+15 IF $$INPINFO^IBAECU2(IB30BACK,IBFL5,IBDFN,"180DAYS",1)=0
QUIT
+16 KILL IBADMINF
SET IBADMINF="^"
+17 SET IBLNGADM=$$DAYS180^IBAECM1(IB30BACK,IBFL5,IBDFN,"180DAYS",.IBADMINF)
End DoDot:1
+18 ; get patient status
+19 SET IBRET1=$$LTCST^IBAECU(IBDFN,IBENDDT,IBLNGADM)
+20 ;calculate a proper LTC Monthly Copay Amount and put it in IBCMC
+21 ;(max amount patient should pay monthly)
+22 ;IS180CLK =1 if patient has >180 days of continious LTC
+23 SET IS180CLK=$$MONTHMAX^IBAECM1(IBDFN,.IBADMINF,IBRET1,IBLNGADM,.IBCMC)
+24 KILL ^TMP($JOB,"180DAYS")
+25 QUIT +IBCMC_"^"_IS180CLK
+26 ;
