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