IBAMTS3 ;LIBERTY/RED - HRfS API's for SHRPE/Nightly process for recent Activations ; 23-DEC-17
;;2.0;INTEGRATED BILLING;**614,653**;14-jun-17;Build 19
;;Per VA Directive 6402, this routine should not be modified.
;
; ICR 5491 - $$GETFLAG^DGPFAPIU
; ICR 4903 - $$GETINF^DGPFAPIH
; ICR 2056 - GETS^DIQ,$$GET1^DIQ
; ICR 10103 - $$FMADD^XLFDT,$$FMTE^XLFDT
;
Q ;No direct access
;
CHKHRFS(IBDFN,IBSTDT,IBENDDT) ; Function to determine Visit Copay exemption based on HRfS flag (IB*2.0*614/653)
; Also check for the activation of the function in field 70.02 in file 350.9 (IB SITE PARAMETERS)
; Also used to verify date of issue for Rx's, if flag was present
;input: IBDFN - Patient IEN
; IBSTDT - (optional) date to begin looking for the flag
; IBENDDT - (optional) End date to look for Flag, defaults to start date if not entered.
;
;Output: 1 - HRfS flag active on date of service
; 0 - HRfS not active on date of service or SHRPE activation date is NULL
N IBFLAG,RESULT,IBREF,SHRPEDT,IBARR
;Due to legislative requirements, this function is active only after approved, when IB*2.0*614 is released the SHRPE activation date will be null
S SHRPEDT=$$GET1^DIQ(350.9,1,70.02,"I") ; Activation date for SHRPE HRfS copayment calculations/waivers
;
I $G(SHRPEDT)="" Q 0_"^SHRPE copayment adjustments have not been activated yet!" ; Quit if date not active
S IBSTDT=$G(IBSTDT),IBSTDT=$S(IBSTDT="":DT,1:IBSTDT),IBENDDT=$S($G(IBENDDT)="":IBSTDT,1:IBENDDT)
I IBSTDT<SHRPEDT Q 0_"^HRfS Flag wasn't active on date of service" ; Date of service is before activation date, quit
S IBFLAG="HIGH RISK FOR SUICIDE",IBREF=$$GETFLAG^DGPFAPIU(IBFLAG,"N")
I $G(IBREF)="" Q 0_"^Pt doesn't have the HRfS flag" ; Natl flag not found
I $G(IBDFN)="" Q 0 ; No Pt entered
S RESULT=$$GETINF^DGPFAPIH(IBDFN,IBREF,IBSTDT,IBENDDT,"IBARR")
I RESULT=0 Q 0_"^HRfS flag NOT active for this Pt at date of service"
Q 1_"^HRfS flag is active at date of service"
;
;Ran nightly as part of ^IBAMTS to see if a patient was assigned the CAT I National HRfS flag the date of service (yesterday),
; or if the same flag was active the day before yesterday and inactivated on the date of service. This generates the bulletin below
NIGHTLY ; called by ^IBAMTC
N IBDFN,IBBILL,IBDT,IBCDT,IBBILLA,IBDATA,IBBILLI,IBBILLP,IBBILLR,IBREF,IBCANC,IBPASTD,IBCNT,IBSTATUS
S (IBCNT,IBDFN)=0,(IBDT,IBCDT)=$$FMADD^XLFDT(DT,-1) ;Use today-1 for the date
S IBCDT=$P(IBCDT,".")_.9999,IBPASTD=$$FMADD^XLFDT(DT,-2) ;Set end of the day and a value for day before
F S IBDT=$O(^IB("D",IBDT)) Q:'IBDT!(IBDT>IBCDT) D
. S IBBILLI=0 F S IBBILLI=$O(^IB("D",IBDT,IBBILLI)) Q:'IBBILLI D
.. K IBDATA D GETS^DIQ(350,IBBILLI_",",".01;.02;.04;.05;.08;.1;.11;.16","IE","IBDATA") S IBDATA=$NA(IBDATA(350,IBBILLI_","))
.. S IBDFN=@IBDATA@(.02,"I"),IBSTATUS=$G(@IBDATA@(.05,"I")),IBBILLR=$G(@IBDATA@(.08,"I"))
.. S IBBILLR=IBBILLR_" : "_$S(@IBDATA@(.11,"I")'="":@IBDATA@(.11,"I"),IBSTATUS=8:@IBDATA@(.05,"E"),1:"Pending"),IBBILLP=@IBDATA@(.16,"I")
.. ; If the Patient had the flag yesterday, but didn't have it the day before, or had it previously and didn't have it yesterday do the bulletin
.. I $$CHKHRFS(IBDFN,IBCDT)&'$$CHKHRFS(IBDFN,IBPASTD)!('$$CHKHRFS(IBDFN,IBCDT)&$$CHKHRFS(IBDFN,IBPASTD)) D
... S IBCANC=$G(@IBDATA@(.1,"I")),IBREF=$G(@IBDATA@(.11,"I"))
... Q:IBCANC'="" ;Claim was cancelled, quit
... I $P($G(@IBDATA@(.04,"I")),":")="52",$P(@IBDATA@(.04,"I"),";",2)'="" S $P(IBBILLR,":")=$P(IBBILLR,":")_"(r)" ;Check for a refilled Rx
... I $P($G(@IBDATA@(.04,"I")),":")=350,$P($G(@IBDATA@(.04,"I")),":",2)'=IBBILLI D Q ;Claim was cancelled
... S IBBILLA(IBDFN,IBBILLI)=IBBILLR ;build the array by DFN
S (IBDFN,IBBILLI)=0 F S IBDFN=$O(IBBILLA(IBDFN)) Q:'IBDFN D
. S IBCNT=1,IBBILLI=0 K IBBILL F S IBBILLI=$O(IBBILLA(IBDFN,IBBILLI)) Q:IBBILLI="" S IBBILL(IBCNT)=IBBILLA(IBDFN,IBBILLI),IBCNT=IBCNT+1
. D BULL(IBDFN) ;send the bulletin for each patient individually
Q
;
;Send bulletin to mailgroup: 'IB MEANS TEST' when HRfS patients are billed on the date of service or were active the day before service
; but deactivated on date of service to allow IB Revenue users to review
BULL(IBDFN) ; Bulletin generation
N IBT,IBC,IBPT,IBDUZ,XMSUB,IBCLAIM
S IBPT=$$PT^IBEFUNC(IBDFN),IBPT=$P(IBPT,U)_U_$P($E(IBPT,1),U)_$P($P(IBPT,U,2),"-",3) ;Pt name (terminal digit)
S XMSUB="IB SHRPE 'HRfS' IB charges review for "_$$FMTE^XLFDT(DT,5)
S IBT(1)=" "
S IBT(2)="The following patient had the HRfS (Cat I) flag activated/inactivated,"
S IBT(3)="and the following charges created on "_$$FMTE^XLFDT($P(IBCDT,"."),5)_" should be reviewed by"
S IBT(4)="IB revenue staff: "
S IBT(5)=" ",IBC=5
S IBDUZ=".5" D PAT^IBAERR1
S IBCLAIM=0 F S IBCLAIM=$O(IBBILL(IBCLAIM)) Q:'IBCLAIM D
. S IBC=IBC+1,IBT(IBC)=" "_IBBILL(IBCLAIM)
D MAIL^IBAERR1
K X,Y,XMSUB,XMY,XMTEXT,XMDUZ
Q
;
;END OF IBAMTS3 routine
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAMTS3 5143 printed Dec 13, 2024@02:06:43 Page 2
IBAMTS3 ;LIBERTY/RED - HRfS API's for SHRPE/Nightly process for recent Activations ; 23-DEC-17
+1 ;;2.0;INTEGRATED BILLING;**614,653**;14-jun-17;Build 19
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; ICR 5491 - $$GETFLAG^DGPFAPIU
+5 ; ICR 4903 - $$GETINF^DGPFAPIH
+6 ; ICR 2056 - GETS^DIQ,$$GET1^DIQ
+7 ; ICR 10103 - $$FMADD^XLFDT,$$FMTE^XLFDT
+8 ;
+9 ;No direct access
QUIT
+10 ;
CHKHRFS(IBDFN,IBSTDT,IBENDDT) ; Function to determine Visit Copay exemption based on HRfS flag (IB*2.0*614/653)
+1 ; Also check for the activation of the function in field 70.02 in file 350.9 (IB SITE PARAMETERS)
+2 ; Also used to verify date of issue for Rx's, if flag was present
+3 ;input: IBDFN - Patient IEN
+4 ; IBSTDT - (optional) date to begin looking for the flag
+5 ; IBENDDT - (optional) End date to look for Flag, defaults to start date if not entered.
+6 ;
+7 ;Output: 1 - HRfS flag active on date of service
+8 ; 0 - HRfS not active on date of service or SHRPE activation date is NULL
+9 NEW IBFLAG,RESULT,IBREF,SHRPEDT,IBARR
+10 ;Due to legislative requirements, this function is active only after approved, when IB*2.0*614 is released the SHRPE activation date will be null
+11 ; Activation date for SHRPE HRfS copayment calculations/waivers
SET SHRPEDT=$$GET1^DIQ(350.9,1,70.02,"I")
+12 ;
+13 ; Quit if date not active
IF $GET(SHRPEDT)=""
QUIT 0_"^SHRPE copayment adjustments have not been activated yet!"
+14 SET IBSTDT=$GET(IBSTDT)
SET IBSTDT=$SELECT(IBSTDT="":DT,1:IBSTDT)
SET IBENDDT=$SELECT($GET(IBENDDT)="":IBSTDT,1:IBENDDT)
+15 ; Date of service is before activation date, quit
IF IBSTDT<SHRPEDT
QUIT 0_"^HRfS Flag wasn't active on date of service"
+16 SET IBFLAG="HIGH RISK FOR SUICIDE"
SET IBREF=$$GETFLAG^DGPFAPIU(IBFLAG,"N")
+17 ; Natl flag not found
IF $GET(IBREF)=""
QUIT 0_"^Pt doesn't have the HRfS flag"
+18 ; No Pt entered
IF $GET(IBDFN)=""
QUIT 0
+19 SET RESULT=$$GETINF^DGPFAPIH(IBDFN,IBREF,IBSTDT,IBENDDT,"IBARR")
+20 IF RESULT=0
QUIT 0_"^HRfS flag NOT active for this Pt at date of service"
+21 QUIT 1_"^HRfS flag is active at date of service"
+22 ;
+23 ;Ran nightly as part of ^IBAMTS to see if a patient was assigned the CAT I National HRfS flag the date of service (yesterday),
+24 ; or if the same flag was active the day before yesterday and inactivated on the date of service. This generates the bulletin below
NIGHTLY ; called by ^IBAMTC
+1 NEW IBDFN,IBBILL,IBDT,IBCDT,IBBILLA,IBDATA,IBBILLI,IBBILLP,IBBILLR,IBREF,IBCANC,IBPASTD,IBCNT,IBSTATUS
+2 ;Use today-1 for the date
SET (IBCNT,IBDFN)=0
SET (IBDT,IBCDT)=$$FMADD^XLFDT(DT,-1)
+3 ;Set end of the day and a value for day before
SET IBCDT=$PIECE(IBCDT,".")_.9999
SET IBPASTD=$$FMADD^XLFDT(DT,-2)
+4 FOR
SET IBDT=$ORDER(^IB("D",IBDT))
if 'IBDT!(IBDT>IBCDT)
QUIT
Begin DoDot:1
+5 SET IBBILLI=0
FOR
SET IBBILLI=$ORDER(^IB("D",IBDT,IBBILLI))
if 'IBBILLI
QUIT
Begin DoDot:2
+6 KILL IBDATA
DO GETS^DIQ(350,IBBILLI_",",".01;.02;.04;.05;.08;.1;.11;.16","IE","IBDATA")
SET IBDATA=$NAME(IBDATA(350,IBBILLI_","))
+7 SET IBDFN=@IBDATA@(.02,"I")
SET IBSTATUS=$GET(@IBDATA@(.05,"I"))
SET IBBILLR=$GET(@IBDATA@(.08,"I"))
+8 SET IBBILLR=IBBILLR_" : "_$SELECT(@IBDATA@(.11,"I")'="":@IBDATA@(.11,"I"),IBSTATUS=8:@IBDATA@(.05,"E"),1:"Pending")
SET IBBILLP=@IBDATA@(.16,"I")
+9 ; If the Patient had the flag yesterday, but didn't have it the day before, or had it previously and didn't have it yesterday do the bulletin
+10 IF $$CHKHRFS(IBDFN,IBCDT)&'$$CHKHRFS(IBDFN,IBPASTD)!('$$CHKHRFS(IBDFN,IBCDT)&$$CHKHRFS(IBDFN,IBPASTD))
Begin DoDot:3
+11 SET IBCANC=$GET(@IBDATA@(.1,"I"))
SET IBREF=$GET(@IBDATA@(.11,"I"))
+12 ;Claim was cancelled, quit
if IBCANC'=""
QUIT
+13 ;Check for a refilled Rx
IF $PIECE($GET(@IBDATA@(.04,"I")),":")="52"
IF $PIECE(@IBDATA@(.04,"I"),";",2)'=""
SET $PIECE(IBBILLR,":")=$PIECE(IBBILLR,":")_"(r)"
+14 ;Claim was cancelled
IF $PIECE($GET(@IBDATA@(.04,"I")),":")=350
IF $PIECE($GET(@IBDATA@(.04,"I")),":",2)'=IBBILLI
Begin DoDot:4
End DoDot:4
QUIT
+15 ;build the array by DFN
SET IBBILLA(IBDFN,IBBILLI)=IBBILLR
End DoDot:3
End DoDot:2
End DoDot:1
+16 SET (IBDFN,IBBILLI)=0
FOR
SET IBDFN=$ORDER(IBBILLA(IBDFN))
if 'IBDFN
QUIT
Begin DoDot:1
+17 SET IBCNT=1
SET IBBILLI=0
KILL IBBILL
FOR
SET IBBILLI=$ORDER(IBBILLA(IBDFN,IBBILLI))
if IBBILLI=""
QUIT
SET IBBILL(IBCNT)=IBBILLA(IBDFN,IBBILLI)
SET IBCNT=IBCNT+1
+18 ;send the bulletin for each patient individually
DO BULL(IBDFN)
End DoDot:1
+19 QUIT
+20 ;
+21 ;Send bulletin to mailgroup: 'IB MEANS TEST' when HRfS patients are billed on the date of service or were active the day before service
+22 ; but deactivated on date of service to allow IB Revenue users to review
BULL(IBDFN) ; Bulletin generation
+1 NEW IBT,IBC,IBPT,IBDUZ,XMSUB,IBCLAIM
+2 ;Pt name (terminal digit)
SET IBPT=$$PT^IBEFUNC(IBDFN)
SET IBPT=$PIECE(IBPT,U)_U_$PIECE($EXTRACT(IBPT,1),U)_$PIECE($PIECE(IBPT,U,2),"-",3)
+3 SET XMSUB="IB SHRPE 'HRfS' IB charges review for "_$$FMTE^XLFDT(DT,5)
+4 SET IBT(1)=" "
+5 SET IBT(2)="The following patient had the HRfS (Cat I) flag activated/inactivated,"
+6 SET IBT(3)="and the following charges created on "_$$FMTE^XLFDT($PIECE(IBCDT,"."),5)_" should be reviewed by"
+7 SET IBT(4)="IB revenue staff: "
+8 SET IBT(5)=" "
SET IBC=5
+9 SET IBDUZ=".5"
DO PAT^IBAERR1
+10 SET IBCLAIM=0
FOR
SET IBCLAIM=$ORDER(IBBILL(IBCLAIM))
if 'IBCLAIM
QUIT
Begin DoDot:1
+11 SET IBC=IBC+1
SET IBT(IBC)=" "_IBBILL(IBCLAIM)
End DoDot:1
+12 DO MAIL^IBAERR1
+13 KILL X,Y,XMSUB,XMY,XMTEXT,XMDUZ
+14 QUIT
+15 ;
+16 ;END OF IBAMTS3 routine
