RCHRFSUT ;SLC/SS - High Risk for Suicide Patients Report Utilities ; JAN 22,2021@14:32
;;4.5;Accounts Receivable;**379**;Mar 20, 1995;Build 16
;;Per VA Directive 6402, this routine should not be modified.
;
;External References Type ICR #
;------------------- ---------- -----
; $$GETALL^DGPFAA Contr. Sub. 7107
; $$GETASGN^DGPFAA Contr. Sub. 7107
; $$GETALLDT^DGPFAAH Contr. Sub. 7214
; $$GETHIST^DGPFAAH Contr. Sub. 7108
; $$GETINF^DGPFAPIH Contr. Sub. 4903
; $$GETFLAG^DGPFAPIU Contr. Sub. 5491
; $$GET1^DIQ Supported 2056
; EN^DIQ1 Supported 10015
; $$FMTE^XLFDT Supported 10103
; $$STRIP^XLFSTR Supported 10104
; File (#350.9), Private 7228
; field (#70.02)
;
;Activation date for HRfS copayment calculations/waivers legislation
HRFSDATE() ;
Q $$GET1^DIQ(350.9,1,70.02,"I") ; Activation date for SHRPE HRfS copayment calculations/waivers
;
;get patient's name and SSN and also return the DFN
PATINFO(DFN) ;
N RCPAT
S DIC=2,DR=".01:.09",DA=DFN,DIQ="RCPAT",DIQ(0)="E" D EN^DIQ1
I $G(RCPAT(2,DFN,.01,"E"))="" Q ""
Q RCPAT(2,DFN,.01,"E")_U_RCPAT(2,DFN,.09,"E")_U_DFN
;
;return 0 if the patient never had HRfS
;return 1 if the patient has or had HRfS, and it does NOT matter if HRFS is active or inactive now
HRFSINFO(RCDFN) ;
Q $$HRFSEVER(RCDFN)
;
;check if patient ever had HRFS flag
;if no PRFs at all then return 0
HRFSEVER(RCDFN) ;
N RCIENS,RCIEN,RCRET,RCFLAGS
; 7107 - GETALL^DGPFAA- Need to subscribe
S RCRET=$$GETALL^DGPFAA(RCDFN,.RCIENS,"",1)
;if no PRFs at all then return 0
I 'RCRET Q 0
;check if at least one of them is HRFS - does not matter active or inactive
S RCRET=0,RCIEN=0
F S RCIEN=$O(RCIENS(RCIEN)) Q:+RCIEN=0!(RCRET=1) D
. ; ICR 7107 GETASGN^DGPFAA
. I '$$GETASGN^DGPFAA(RCIEN,.RCFLAGS) Q
. I $P(RCFLAGS("FLAG"),U,2)="HIGH RISK FOR SUICIDE" S RCRET=1
Q RCRET
;
;Was patient's HRfS active at least for one day during the date period if dates are provided?
;return:
; 0 - no
; 1 - yes
HASHRFS(RCDFN,RCSTRDT,RCENDDT) ;
N RCRET,RETARR
S RCRET=$$PRFHIST(RCDFN,.RETARR,RCSTRDT,RCENDDT)
Q +RCRET
;
;*******
;get HRfS dates
;For the date given, determine:
; 1st piece - if HRFS flag was active (even if it was active for a second on that day - i.e. include any changes in status even except CONTINUE)
; 2nd piece - the closest activation date/time (before or on RCDOS)
; 0 if nothing
; 3rd piece - the closest inactivation date/time (after or on RCDOS)
; 0 if nothing
HRFSDTS(RCDFN,RCDOS) ;
N RETVAL,RETARR,RCACTDT,RCINACT,RCZ,RCZ2
;was HRFS flag active on the date of service?
S RETVAL=0
;get array with the history
I $$PRFHIST(RCDFN,.RETARR,RCDOS\1-.0000001,RCDOS\1+.9999999)
;if no array then return the $$CHKHRFS result
I '$D(RETARR) Q RETVAL
;check it was active on that date
S RETVAL=$$CHKACT(.RETARR,RCDOS)
;if was active on DOS
I RETVAL=1 D Q "YES"_U_RCACTDT_U_RCINACT
. ;find closest "activation" type change in the past
. S RCACTDT=+$$FNDACT(.RETARR,RCDOS,-1)
. ;find closest "inactivation" type change in the future after this date
. S RCINACT=+$$FNDINACT(.RETARR,RCACTDT,1,1)
. ;convert to the user-friendly format
. S RCACTDT=$S(RCACTDT>0:$$STRIP^XLFSTR($$FMTE^XLFDT(RCACTDT\1,"8D")," "),1:"")
. S RCINACT=$S(RCINACT>0:$$STRIP^XLFSTR($$FMTE^XLFDT(RCINACT\1,"8D")," "),1:"ACTIVE")
Q "NO^NO FLAG^NO FLAG"
;
;check if the flag is active on that date
;find closest changes in the past
;if one of REACTIVATE^NEW ASSIGNMENT^CONTINUE on that date before return 1
;NOTE : if one of REACTIVATE^NEW ASSIGNMENT^CONTINUE on that same date then the flag is active and return 1
;if others then return 0
CHKACT(RCARR,RCDATE) ;
N DTTM,DTTIME,RCFOUND
S RCFOUND=0
S DTTIME=RCDATE\1
S DTTM=DTTIME+.9999999
F S DTTM=$O(RCARR("HIGH RISK FOR SUICIDE",DTTM),-1) Q:'DTTM D Q:RCFOUND=1 I RCFOUND=-1,DTTM<DTTIME Q
. I "^REACTIVATE^NEW ASSIGNMENT^"[("^"_$P(RETARR("HIGH RISK FOR SUICIDE",DTTM),U,2)_"^") S RCFOUND=1
. E S RCFOUND=-1
Q RCFOUND
;
;find closest "activation" type change in the past or in the future
;RCARR - array with history
;DTTIME - starting date/time for the search
;DIRECT - direction:
; -1 - closest in the past
; 1 - closest in the future
;USEASIS - if 1 then use the date as is - don't add .999999 or subtract .00000001 (default is 0)
FNDACT(RCARR,DTTIME,DIRECT,USEASIS) ;
N DTTM
S DTTM=DTTIME
I +$G(USEASIS)=0,DIRECT=1 S DTTM=DTTM\1-.0000001
I +$G(USEASIS)=0,DIRECT=-1 S DTTM=DTTM\1+.9999999
F S DTTM=$O(RCARR("HIGH RISK FOR SUICIDE",DTTM),DIRECT) Q:'DTTM I "^REACTIVATE^NEW ASSIGNMENT^"[("^"_$P(RETARR("HIGH RISK FOR SUICIDE",DTTM),U,2)_"^") Q
Q DTTM
;
;find closest "inactivation" type change in the future
;RCARR - array with history
;DTTIME - starting date/time for the search
;DIRECT - direction:
; -1 - closest in the past
; 1 - closest in the future
;USEASIS - if 1 then use the date as is - don't add .999999 or subtract .00000001 (default is 0)
FNDINACT(RCARR,DTTIME,DIRECT,USEASIS) ;
N DTTM
S DTTM=DTTIME
I +$G(USEASIS)=0,DIRECT=1 S DTTM=DTTM\1-.0000001
I +$G(USEASIS)=0,DIRECT=-1 S DTTM=DTTM\1+.9999999
F S DTTM=$O(RCARR("HIGH RISK FOR SUICIDE",DTTM),DIRECT) Q:'DTTM I "^INACTIVATE^ENTERED IN ERROR^"[("^"_$P(RETARR("HIGH RISK FOR SUICIDE",DTTM),U,2)_"^") Q
Q DTTM
;
;*******
;Determine if the patient's HRfS was active at least for one day during the date period if dates are provided
;
; get PRF INACTIVATE^REACTIVATE^NEW ASSIGNMENT^ENTERED IN ERROR records for the HRfS flag and return this in the array
; Optionally - check if one of these changes happen within the date range, between RCSTRDT and RCENDDT (both inclusive)
;
;RCDFN - Patient's IEN in the file #2
;RETARR - array to return results
;RCSTRDT - start date
;RCENDDT - end date
;
;return:
; 1st piece =1 if any changes fall within the date range specified (the "date of change" still is considered as the day with ACTIVE HRfS because the status can be changed at any time on that day)
; 2nd piece = date /time of the last status change (INACTIVATE^REACTIVATE^NEW ASSIGNMENT^ENTERED IN ERROR) Note: CONTINUE is not considered as the status change
;
PRFHIST(RCDFN,RETARR,RCSTRDT,RCENDDT) ;
N RCRET,RCIEN13,RCIENS,RCARRH,RCFLGNM,RCARFLAG,RCCNT,RCDTTM,RCIEN14,RCZ,RCRET,RCINRANG,RCDTCHK,RCASGNDT,RCLASTCH
S RCRET=0,RCINRANG=0,RCDTCHK=0,RCLASTCH=0
;if dates were specified and that were specified correctly then we need to return the 2nd piece
I $G(RCSTRDT),$G(RCENDDT) I RCSTRDT'>RCENDDT S RCDTCHK=1
;ICR 7107
I '$$GETALL^DGPFAA(RCDFN,.RCRET,"",1) Q
S RCIEN13="" F S RCIEN13=$O(RCRET(RCIEN13)) Q:RCIEN13="" D
. K RCARFLAG
. ;ICR 7107
. I '$$GETASGN^DGPFAA(RCIEN13,.RCARFLAG) Q
. S RCFLGNM=$P(RCARFLAG("FLAG"),U,2)
. I '$L(RCFLGNM) Q
. I RCFLGNM'="HIGH RISK FOR SUICIDE" Q
. K RCIENS
. ;7214
. I '$$GETALLDT^DGPFAAH(RCIEN13,.RCIENS) Q
. S RCCNT=0
. S RCDTTM="" F S RCDTTM=$O(RCIENS(RCDTTM)) Q:+RCDTTM=0 S RCIEN14=$G(RCIENS(RCDTTM)) I RCIEN14 D
. . K RCARRH
. . ;7108
. . I '$$GETHIST^DGPFAAH(RCIEN14,.RCARRH,1) Q
. . S RCZ="^"_$P(RCARRH("ACTION"),U,2)_"^"
. . ; ignore if the action is not in the list
. . I "^INACTIVATE^REACTIVATE^NEW ASSIGNMENT^ENTERED IN ERROR^"'[RCZ Q
. . S RCCNT=RCCNT+1
. . ;if we need to check if we had any changes within the date range
. . ;if yes then RCINRANG=1
. . I RCDTCHK I +$G(RCARRH("ASSIGNDT"))>0 I ((+RCARRH("ASSIGNDT")\1)'<RCSTRDT),((+RCARRH("ASSIGNDT")\1)'>RCENDDT) S RCINRANG=1
. . S RCASGNDT=+RCARRH("ASSIGNDT")
. . S RETARR(RCFLGNM,RCASGNDT)=$P(RCARRH("ASSIGNDT"),U,2)_U_$P(RCARRH("ACTION"),U,2)
S RCLASTCH=+$O(RETARR("HIGH RISK FOR SUICIDE",999999999999),-1)
;if we needed to check if we had any changes within the date range AND no changes within the date range were found then
;still check if patient's HRFS was active in that date range
I RCDTCHK I RCINRANG=0 I $$CHKACT(.RETARR,$G(RCSTRDT)) S RCINRANG=1
; when was the last update and did we have the change within the range
Q RCINRANG_U_RCLASTCH
;
;
;*******
;Function to determine status of the HRfS flag within the date range
;
;input:
; RCDFN - Patient IEN
; RCSTDT - (optional) date to begin looking for the flag
; RCENDDT - (optional) End date to look for Flag, defaults to start date if not entered.
;
;Output:
; -2 Natl flag not found
; -1 No Pt entered
; 0 HRfS not active withing the date range
; 1 HRfS active withing the date range
CHKHRFS(RCDFN,RCSTDT,RCENDDT) ; Function to determine status of the HRfS flag
I $G(RCDFN)="" Q -1 ; No Pt entered
N RCFLAG,RESULT,RCREF,RCARR
;if no start date then assume from the start of the VistA
S RCSTDT=$G(RCSTDT) I RCSTDT="" S RCSTDT=0
;if no end date then assume until today
S RCENDDT=$G(RCENDDT) I RCENDDT="" S RCENDDT=DT
;Get the variable pointer value for the flag
;ICR 5491
S RCFLAG="HIGH RISK FOR SUICIDE",RCREF=$$GETFLAG^DGPFAPIU(RCFLAG,"N")
I $G(RCREF)="" Q -2 ; Natl flag not found
;ICR 4903
S RESULT=$$GETINF^DGPFAPIH(RCDFN,RCREF,RCSTDT,RCENDDT,"RCARR")
I RESULT=0 Q 0
Q 1
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCHRFSUT 9320 printed Apr 09, 2024@20:52:08 Page 2
RCHRFSUT ;SLC/SS - High Risk for Suicide Patients Report Utilities ; JAN 22,2021@14:32
+1 ;;4.5;Accounts Receivable;**379**;Mar 20, 1995;Build 16
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;External References Type ICR #
+5 ;------------------- ---------- -----
+6 ; $$GETALL^DGPFAA Contr. Sub. 7107
+7 ; $$GETASGN^DGPFAA Contr. Sub. 7107
+8 ; $$GETALLDT^DGPFAAH Contr. Sub. 7214
+9 ; $$GETHIST^DGPFAAH Contr. Sub. 7108
+10 ; $$GETINF^DGPFAPIH Contr. Sub. 4903
+11 ; $$GETFLAG^DGPFAPIU Contr. Sub. 5491
+12 ; $$GET1^DIQ Supported 2056
+13 ; EN^DIQ1 Supported 10015
+14 ; $$FMTE^XLFDT Supported 10103
+15 ; $$STRIP^XLFSTR Supported 10104
+16 ; File (#350.9), Private 7228
+17 ; field (#70.02)
+18 ;
+19 ;Activation date for HRfS copayment calculations/waivers legislation
HRFSDATE() ;
+1 ; Activation date for SHRPE HRfS copayment calculations/waivers
QUIT $$GET1^DIQ(350.9,1,70.02,"I")
+2 ;
+3 ;get patient's name and SSN and also return the DFN
PATINFO(DFN) ;
+1 NEW RCPAT
+2 SET DIC=2
SET DR=".01:.09"
SET DA=DFN
SET DIQ="RCPAT"
SET DIQ(0)="E"
DO EN^DIQ1
+3 IF $GET(RCPAT(2,DFN,.01,"E"))=""
QUIT ""
+4 QUIT RCPAT(2,DFN,.01,"E")_U_RCPAT(2,DFN,.09,"E")_U_DFN
+5 ;
+6 ;return 0 if the patient never had HRfS
+7 ;return 1 if the patient has or had HRfS, and it does NOT matter if HRFS is active or inactive now
HRFSINFO(RCDFN) ;
+1 QUIT $$HRFSEVER(RCDFN)
+2 ;
+3 ;check if patient ever had HRFS flag
+4 ;if no PRFs at all then return 0
HRFSEVER(RCDFN) ;
+1 NEW RCIENS,RCIEN,RCRET,RCFLAGS
+2 ; 7107 - GETALL^DGPFAA- Need to subscribe
+3 SET RCRET=$$GETALL^DGPFAA(RCDFN,.RCIENS,"",1)
+4 ;if no PRFs at all then return 0
+5 IF 'RCRET
QUIT 0
+6 ;check if at least one of them is HRFS - does not matter active or inactive
+7 SET RCRET=0
SET RCIEN=0
+8 FOR
SET RCIEN=$ORDER(RCIENS(RCIEN))
if +RCIEN=0!(RCRET=1)
QUIT
Begin DoDot:1
+9 ; ICR 7107 GETASGN^DGPFAA
+10 IF '$$GETASGN^DGPFAA(RCIEN,.RCFLAGS)
QUIT
+11 IF $PIECE(RCFLAGS("FLAG"),U,2)="HIGH RISK FOR SUICIDE"
SET RCRET=1
End DoDot:1
+12 QUIT RCRET
+13 ;
+14 ;Was patient's HRfS active at least for one day during the date period if dates are provided?
+15 ;return:
+16 ; 0 - no
+17 ; 1 - yes
HASHRFS(RCDFN,RCSTRDT,RCENDDT) ;
+1 NEW RCRET,RETARR
+2 SET RCRET=$$PRFHIST(RCDFN,.RETARR,RCSTRDT,RCENDDT)
+3 QUIT +RCRET
+4 ;
+5 ;*******
+6 ;get HRfS dates
+7 ;For the date given, determine:
+8 ; 1st piece - if HRFS flag was active (even if it was active for a second on that day - i.e. include any changes in status even except CONTINUE)
+9 ; 2nd piece - the closest activation date/time (before or on RCDOS)
+10 ; 0 if nothing
+11 ; 3rd piece - the closest inactivation date/time (after or on RCDOS)
+12 ; 0 if nothing
HRFSDTS(RCDFN,RCDOS) ;
+1 NEW RETVAL,RETARR,RCACTDT,RCINACT,RCZ,RCZ2
+2 ;was HRFS flag active on the date of service?
+3 SET RETVAL=0
+4 ;get array with the history
+5 IF $$PRFHIST(RCDFN,.RETARR,RCDOS\1-.0000001,RCDOS\1+.9999999)
+6 ;if no array then return the $$CHKHRFS result
+7 IF '$DATA(RETARR)
QUIT RETVAL
+8 ;check it was active on that date
+9 SET RETVAL=$$CHKACT(.RETARR,RCDOS)
+10 ;if was active on DOS
+11 IF RETVAL=1
Begin DoDot:1
+12 ;find closest "activation" type change in the past
+13 SET RCACTDT=+$$FNDACT(.RETARR,RCDOS,-1)
+14 ;find closest "inactivation" type change in the future after this date
+15 SET RCINACT=+$$FNDINACT(.RETARR,RCACTDT,1,1)
+16 ;convert to the user-friendly format
+17 SET RCACTDT=$SELECT(RCACTDT>0:$$STRIP^XLFSTR($$FMTE^XLFDT(RCACTDT\1,"8D")," "),1:"")
+18 SET RCINACT=$SELECT(RCINACT>0:$$STRIP^XLFSTR($$FMTE^XLFDT(RCINACT\1,"8D")," "),1:"ACTIVE")
End DoDot:1
QUIT "YES"_U_RCACTDT_U_RCINACT
+19 QUIT "NO^NO FLAG^NO FLAG"
+20 ;
+21 ;check if the flag is active on that date
+22 ;find closest changes in the past
+23 ;if one of REACTIVATE^NEW ASSIGNMENT^CONTINUE on that date before return 1
+24 ;NOTE : if one of REACTIVATE^NEW ASSIGNMENT^CONTINUE on that same date then the flag is active and return 1
+25 ;if others then return 0
CHKACT(RCARR,RCDATE) ;
+1 NEW DTTM,DTTIME,RCFOUND
+2 SET RCFOUND=0
+3 SET DTTIME=RCDATE\1
+4 SET DTTM=DTTIME+.9999999
+5 FOR
SET DTTM=$ORDER(RCARR("HIGH RISK FOR SUICIDE",DTTM),-1)
if 'DTTM
QUIT
Begin DoDot:1
+6 IF "^REACTIVATE^NEW ASSIGNMENT^"[("^"_$PIECE(RETARR("HIGH RISK FOR SUICIDE",DTTM),U,2)_"^")
SET RCFOUND=1
+7 IF '$TEST
SET RCFOUND=-1
End DoDot:1
if RCFOUND=1
QUIT
IF RCFOUND=-1
IF DTTM<DTTIME
QUIT
+8 QUIT RCFOUND
+9 ;
+10 ;find closest "activation" type change in the past or in the future
+11 ;RCARR - array with history
+12 ;DTTIME - starting date/time for the search
+13 ;DIRECT - direction:
+14 ; -1 - closest in the past
+15 ; 1 - closest in the future
+16 ;USEASIS - if 1 then use the date as is - don't add .999999 or subtract .00000001 (default is 0)
FNDACT(RCARR,DTTIME,DIRECT,USEASIS) ;
+1 NEW DTTM
+2 SET DTTM=DTTIME
+3 IF +$GET(USEASIS)=0
IF DIRECT=1
SET DTTM=DTTM\1-.0000001
+4 IF +$GET(USEASIS)=0
IF DIRECT=-1
SET DTTM=DTTM\1+.9999999
+5 FOR
SET DTTM=$ORDER(RCARR("HIGH RISK FOR SUICIDE",DTTM),DIRECT)
if 'DTTM
QUIT
IF "^REACTIVATE^NEW ASSIGNMENT^"[("^"_$PIECE(RETARR("HIGH RISK FOR SUICIDE",DTTM),U,2)_"^")
QUIT
+6 QUIT DTTM
+7 ;
+8 ;find closest "inactivation" type change in the future
+9 ;RCARR - array with history
+10 ;DTTIME - starting date/time for the search
+11 ;DIRECT - direction:
+12 ; -1 - closest in the past
+13 ; 1 - closest in the future
+14 ;USEASIS - if 1 then use the date as is - don't add .999999 or subtract .00000001 (default is 0)
FNDINACT(RCARR,DTTIME,DIRECT,USEASIS) ;
+1 NEW DTTM
+2 SET DTTM=DTTIME
+3 IF +$GET(USEASIS)=0
IF DIRECT=1
SET DTTM=DTTM\1-.0000001
+4 IF +$GET(USEASIS)=0
IF DIRECT=-1
SET DTTM=DTTM\1+.9999999
+5 FOR
SET DTTM=$ORDER(RCARR("HIGH RISK FOR SUICIDE",DTTM),DIRECT)
if 'DTTM
QUIT
IF "^INACTIVATE^ENTERED IN ERROR^"[("^"_$PIECE(RETARR("HIGH RISK FOR SUICIDE",DTTM),U,2)_"^")
QUIT
+6 QUIT DTTM
+7 ;
+8 ;*******
+9 ;Determine if the patient's HRfS was active at least for one day during the date period if dates are provided
+10 ;
+11 ; get PRF INACTIVATE^REACTIVATE^NEW ASSIGNMENT^ENTERED IN ERROR records for the HRfS flag and return this in the array
+12 ; Optionally - check if one of these changes happen within the date range, between RCSTRDT and RCENDDT (both inclusive)
+13 ;
+14 ;RCDFN - Patient's IEN in the file #2
+15 ;RETARR - array to return results
+16 ;RCSTRDT - start date
+17 ;RCENDDT - end date
+18 ;
+19 ;return:
+20 ; 1st piece =1 if any changes fall within the date range specified (the "date of change" still is considered as the day with ACTIVE HRfS because the status can be changed at any time on that day)
+21 ; 2nd piece = date /time of the last status change (INACTIVATE^REACTIVATE^NEW ASSIGNMENT^ENTERED IN ERROR) Note: CONTINUE is not considered as the status change
+22 ;
PRFHIST(RCDFN,RETARR,RCSTRDT,RCENDDT) ;
+1 NEW RCRET,RCIEN13,RCIENS,RCARRH,RCFLGNM,RCARFLAG,RCCNT,RCDTTM,RCIEN14,RCZ,RCRET,RCINRANG,RCDTCHK,RCASGNDT,RCLASTCH
+2 SET RCRET=0
SET RCINRANG=0
SET RCDTCHK=0
SET RCLASTCH=0
+3 ;if dates were specified and that were specified correctly then we need to return the 2nd piece
+4 IF $GET(RCSTRDT)
IF $GET(RCENDDT)
IF RCSTRDT'>RCENDDT
SET RCDTCHK=1
+5 ;ICR 7107
+6 IF '$$GETALL^DGPFAA(RCDFN,.RCRET,"",1)
QUIT
+7 SET RCIEN13=""
FOR
SET RCIEN13=$ORDER(RCRET(RCIEN13))
if RCIEN13=""
QUIT
Begin DoDot:1
+8 KILL RCARFLAG
+9 ;ICR 7107
+10 IF '$$GETASGN^DGPFAA(RCIEN13,.RCARFLAG)
QUIT
+11 SET RCFLGNM=$PIECE(RCARFLAG("FLAG"),U,2)
+12 IF '$LENGTH(RCFLGNM)
QUIT
+13 IF RCFLGNM'="HIGH RISK FOR SUICIDE"
QUIT
+14 KILL RCIENS
+15 ;7214
+16 IF '$$GETALLDT^DGPFAAH(RCIEN13,.RCIENS)
QUIT
+17 SET RCCNT=0
+18 SET RCDTTM=""
FOR
SET RCDTTM=$ORDER(RCIENS(RCDTTM))
if +RCDTTM=0
QUIT
SET RCIEN14=$GET(RCIENS(RCDTTM))
IF RCIEN14
Begin DoDot:2
+19 KILL RCARRH
+20 ;7108
+21 IF '$$GETHIST^DGPFAAH(RCIEN14,.RCARRH,1)
QUIT
+22 SET RCZ="^"_$PIECE(RCARRH("ACTION"),U,2)_"^"
+23 ; ignore if the action is not in the list
+24 IF "^INACTIVATE^REACTIVATE^NEW ASSIGNMENT^ENTERED IN ERROR^"'[RCZ
QUIT
+25 SET RCCNT=RCCNT+1
+26 ;if we need to check if we had any changes within the date range
+27 ;if yes then RCINRANG=1
+28 IF RCDTCHK
IF +$GET(RCARRH("ASSIGNDT"))>0
IF ((+RCARRH("ASSIGNDT")\1)'<RCSTRDT)
IF ((+RCARRH("ASSIGNDT")\1)'>RCENDDT)
SET RCINRANG=1
+29 SET RCASGNDT=+RCARRH("ASSIGNDT")
+30 SET RETARR(RCFLGNM,RCASGNDT)=$PIECE(RCARRH("ASSIGNDT"),U,2)_U_$PIECE(RCARRH("ACTION"),U,2)
End DoDot:2
End DoDot:1
+31 SET RCLASTCH=+$ORDER(RETARR("HIGH RISK FOR SUICIDE",999999999999),-1)
+32 ;if we needed to check if we had any changes within the date range AND no changes within the date range were found then
+33 ;still check if patient's HRFS was active in that date range
+34 IF RCDTCHK
IF RCINRANG=0
IF $$CHKACT(.RETARR,$GET(RCSTRDT))
SET RCINRANG=1
+35 ; when was the last update and did we have the change within the range
+36 QUIT RCINRANG_U_RCLASTCH
+37 ;
+38 ;
+39 ;*******
+40 ;Function to determine status of the HRfS flag within the date range
+41 ;
+42 ;input:
+43 ; RCDFN - Patient IEN
+44 ; RCSTDT - (optional) date to begin looking for the flag
+45 ; RCENDDT - (optional) End date to look for Flag, defaults to start date if not entered.
+46 ;
+47 ;Output:
+48 ; -2 Natl flag not found
+49 ; -1 No Pt entered
+50 ; 0 HRfS not active withing the date range
+51 ; 1 HRfS active withing the date range
CHKHRFS(RCDFN,RCSTDT,RCENDDT) ; Function to determine status of the HRfS flag
+1 ; No Pt entered
IF $GET(RCDFN)=""
QUIT -1
+2 NEW RCFLAG,RESULT,RCREF,RCARR
+3 ;if no start date then assume from the start of the VistA
+4 SET RCSTDT=$GET(RCSTDT)
IF RCSTDT=""
SET RCSTDT=0
+5 ;if no end date then assume until today
+6 SET RCENDDT=$GET(RCENDDT)
IF RCENDDT=""
SET RCENDDT=DT
+7 ;Get the variable pointer value for the flag
+8 ;ICR 5491
+9 SET RCFLAG="HIGH RISK FOR SUICIDE"
SET RCREF=$$GETFLAG^DGPFAPIU(RCFLAG,"N")
+10 ; Natl flag not found
IF $GET(RCREF)=""
QUIT -2
+11 ;ICR 4903
+12 SET RESULT=$$GETINF^DGPFAPIH(RCDFN,RCREF,RCSTDT,RCENDDT,"RCARR")
+13 IF RESULT=0
QUIT 0
+14 QUIT 1
+15 ;
