DGPFAPIU ;ALB/SCK - PRF API UTILITIES FOR HIGH RISK MENTAL HEALTH ;Jan 21, 2011
;;5.3;Registration;**836,971**;Aug 13, 1993;Build 5
;
Q ; No direct entry
;
CHKDATE(DGSTART,DGEND,DGRANGE) ; Check for valid start and end dates, set DGRANGE parameter
N DGRSLT
;
S DGSTART=+$G(DGSTART),DGEND=+$G(DGEND)
S:DGSTART<0 DGSTART=0
;
I 'DGSTART&('DGEND) D
. S DGRANGE="A"
. S DGSTART=0,DGEND=$P($$NOW^XLFDT,".")
E D
. S DGRANGE="S"
;
S DGRANGE("START")=DGSTART,DGRANGE("END")=DGEND
Q 1
;
CHKDFN(DGDFN,DGNAME) ; Check for a valid entry in the PATIENT file
N DGERR,DGRSLT
;
S DGRSLT=1
S DGNAME=$$GET1^DIQ(2,DGDFN,.01,,,"DGERR")
I $D(DGERR) S DGRSLT=0,DGNAME=DGERR("DIERR",1,"TEXT",1)
Q $G(DGRSLT)
;
ASGNDATE(DGIEN) ; Get intial assignment date from new record history entry
N DGRSLT,DGX
;
S DGX=0
F S DGX=$O(^DGPF(26.14,"B",DGIEN,DGX)) Q:'DGX D
. I $P($G(^DGPF(26.14,DGX,0)),U,3)=1 S DGRSLT=$P($G(^DGPF(26.14,DGX,0)),U,2)
;
Q +$G(DGRSLT)
;
GETFLAG(DGPRF,DGCAT) ; Get the variable pointer value for the flag text passed in
; Input: DGPRF - Flag name, i.e. BEHAVIORAL
; DGCAT - Flag Category, N - National [Optional]
; L - Local
;
; Output: Returns the variable pointer value for the flag, i.e. "1;DGPF(25.15"
; If not found, returns "-1;NOT FOUND"
; If not Active, returns "-1;NOt ACTIVE"
;
N DGIEN,DGDONE,DGRSLT,DGSTAT
;
S DGCAT=$G(DGCAT)
S DGCAT=$S(DGCAT="N":1,DGCAT="L":2,1:0)
;
I DGCAT=1 D
. S DGIEN=$O(^DGPF(26.15,"B",DGPRF,0))
. I DGIEN S DGDONE=1,DGRSLT=DGIEN_";DGPF(26.15,"
;
I DGCAT=2 D
. S DGIEN=$O(^DGPF(26.11,"B",DGPRF,0))
. I DGIEN S DGDONE=1,DGRSLT=DGIEN_";DGPF(26.11,"
;
I DGCAT=0 D
. ; Check the PRF local flag file for the flag first. If found, return the appropriate variable pointer
. S DGIEN=$O(^DGPF(26.11,"B",DGPRF,0))
. I DGIEN S DGDONE=1,DGRSLT=DGIEN_";DGPF(26.11,"
. ; If not found in the PRF Local Flag file, then check the PRF National Flag file. If found, return the appropriate variable pointer.
. I '$G(DGDONE) D
.. S DGIEN=$O(^DGPF(26.15,"B",DGPRF,0))
.. I DGIEN S DGDONE=1,DGRSLT=DGIEN_";DGPF(26.15,"
;
I '$G(DGDONE) S DGRSLT="-1;NOT FOUND"
;
; Check active status
I +$G(DGRSLT)>0 D
. S DGSTAT=$$GET1^DIQ($S(DGRSLT[26.11:26.11,1:26.15),+DGRSLT,.02,"I")
. I 'DGSTAT S DGRSLT="-1;NOT ACTIVE"
;
Q $G(DGRSLT)
;
ACTIVE(DGIEN,DGRANGE) ; Check if "active" during date range
; Input
; DGIEN - Pointer to PRF Assignment File (#26.13)
; DGRANGE - Array containg Start Date/End Date
;
; Output
; DGRSLT: 1 - "Active"
; 0 - "Not Active"
;
N DGDT,DGX,DGACT,DGRSLT,DGACT2,DGPRE,DGPST,DGRSLT,DGCNT,DGDTPRE,DGDTPST
;
S DGRSLT=0
; Build array of actions fro processing
S (DGCNT,DGDT)=0
F S DGDT=$O(^DGPF(26.14,"C",DGIEN,DGDT)) Q:'DGDT D
. S DGX=$O(^DGPF(26.14,"C",DGIEN,DGDT,0)) Q:'DGX
. S DGACT(DGX)=$P($G(^DGPF(26.14,DGX,0)),U,3)_"^"_$P($P($G(^DGPF(26.14,DGX,0)),U,2),".")
. S DGCNT=DGCNT+1
S DGACT=DGCNT
;
; Check for last action of Entered in Error, if there is one, all previous actions are void
; Quit, returning inactive status
S DGX=$O(DGACT(99999999),-1)
I $P(DGACT(DGX),U)=5 S DGRSLT=0 G CHKQ
;
; Begin checking history file
I DGRANGE["A" D
. I DGACT=1 D ; If only one entry, should be NEW, process as active
.. S DGX=$O(DGACT(0))
.. S DGRSLT=$S($P(DGACT(DGX),U)=1:1,1:0)
. E D
.. S DGX=$O(DGACT(99999999),-1)
.. I "3,5"[$P(DGACT(DGX),U) S DGRSLT=0 ; Check last entry for EiE or Inact
.. E S DGRSLT=1
E D
. I $P($$ASGNDATE^DGPFAPIU(DGIEN),".")>DGRANGE("END") S DGRSLT=0 Q
. S (DGACT2,DGX)=0
. F S DGX=$O(DGACT(DGX)) Q:'DGX D
.. I $P(DGACT(DGX),U,2)>DGRANGE("START")&($P(DGACT(DGX),U,2)<=DGRANGE("END")) S DGACT2(DGX)=DGACT(DGX),DGACT2=DGACT2+1 ; DG*971 Inclusive Range
. ; If actions are found within the date range, process for active status.
. I DGACT2>0 D
.. S DGX=0 F S DGX=$O(DGACT2(DGX)) Q:'DGX D
... S DGRSLT=$S("1,2,4"[$P(DGACT2(DGX),U):1,1:0)
. ; If no action entry is found within the date range specified, then try to determine the status from
. ; the nearest action.
. E D
.. S DGDTPRE=DGRANGE("START")_".999999"
.. S DGDTPRE=$O(^DGPF(26.14,"C",DGIEN,DGDTPRE),-1)
.. S DGPRE=$S(DGDTPRE>0:$O(^DGPF(26.14,"C",DGIEN,DGDTPRE,0)),1:0)
.. S DGDTPST=$O(^DGPF(26.14,"C",DGIEN,DGRANGE("END")))
.. S DGPST=$S(DGDTPST>0:$O(^DGPF(26.14,"C",DGIEN,DGDTPST,0)),1:0)
.. S DGRSLT=$S("1,2,4"[$P(DGACT(DGPRE),U):1,1:0)
.. I DGPST>0,$P(DGACT(DGPST),U)="5" S DGRSLT=0
;
CHKQ ;
;
Q +$G(DGRSLT)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFAPIU 4677 printed Sep 23, 2025@20:23:22 Page 2
DGPFAPIU ;ALB/SCK - PRF API UTILITIES FOR HIGH RISK MENTAL HEALTH ;Jan 21, 2011
+1 ;;5.3;Registration;**836,971**;Aug 13, 1993;Build 5
+2 ;
+3 ; No direct entry
QUIT
+4 ;
CHKDATE(DGSTART,DGEND,DGRANGE) ; Check for valid start and end dates, set DGRANGE parameter
+1 NEW DGRSLT
+2 ;
+3 SET DGSTART=+$GET(DGSTART)
SET DGEND=+$GET(DGEND)
+4 if DGSTART<0
SET DGSTART=0
+5 ;
+6 IF 'DGSTART&('DGEND)
Begin DoDot:1
+7 SET DGRANGE="A"
+8 SET DGSTART=0
SET DGEND=$PIECE($$NOW^XLFDT,".")
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 SET DGRANGE="S"
End DoDot:1
+11 ;
+12 SET DGRANGE("START")=DGSTART
SET DGRANGE("END")=DGEND
+13 QUIT 1
+14 ;
CHKDFN(DGDFN,DGNAME) ; Check for a valid entry in the PATIENT file
+1 NEW DGERR,DGRSLT
+2 ;
+3 SET DGRSLT=1
+4 SET DGNAME=$$GET1^DIQ(2,DGDFN,.01,,,"DGERR")
+5 IF $DATA(DGERR)
SET DGRSLT=0
SET DGNAME=DGERR("DIERR",1,"TEXT",1)
+6 QUIT $GET(DGRSLT)
+7 ;
ASGNDATE(DGIEN) ; Get intial assignment date from new record history entry
+1 NEW DGRSLT,DGX
+2 ;
+3 SET DGX=0
+4 FOR
SET DGX=$ORDER(^DGPF(26.14,"B",DGIEN,DGX))
if 'DGX
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^DGPF(26.14,DGX,0)),U,3)=1
SET DGRSLT=$PIECE($GET(^DGPF(26.14,DGX,0)),U,2)
End DoDot:1
+6 ;
+7 QUIT +$GET(DGRSLT)
+8 ;
GETFLAG(DGPRF,DGCAT) ; Get the variable pointer value for the flag text passed in
+1 ; Input: DGPRF - Flag name, i.e. BEHAVIORAL
+2 ; DGCAT - Flag Category, N - National [Optional]
+3 ; L - Local
+4 ;
+5 ; Output: Returns the variable pointer value for the flag, i.e. "1;DGPF(25.15"
+6 ; If not found, returns "-1;NOT FOUND"
+7 ; If not Active, returns "-1;NOt ACTIVE"
+8 ;
+9 NEW DGIEN,DGDONE,DGRSLT,DGSTAT
+10 ;
+11 SET DGCAT=$GET(DGCAT)
+12 SET DGCAT=$SELECT(DGCAT="N":1,DGCAT="L":2,1:0)
+13 ;
+14 IF DGCAT=1
Begin DoDot:1
+15 SET DGIEN=$ORDER(^DGPF(26.15,"B",DGPRF,0))
+16 IF DGIEN
SET DGDONE=1
SET DGRSLT=DGIEN_";DGPF(26.15,"
End DoDot:1
+17 ;
+18 IF DGCAT=2
Begin DoDot:1
+19 SET DGIEN=$ORDER(^DGPF(26.11,"B",DGPRF,0))
+20 IF DGIEN
SET DGDONE=1
SET DGRSLT=DGIEN_";DGPF(26.11,"
End DoDot:1
+21 ;
+22 IF DGCAT=0
Begin DoDot:1
+23 ; Check the PRF local flag file for the flag first. If found, return the appropriate variable pointer
+24 SET DGIEN=$ORDER(^DGPF(26.11,"B",DGPRF,0))
+25 IF DGIEN
SET DGDONE=1
SET DGRSLT=DGIEN_";DGPF(26.11,"
+26 ; If not found in the PRF Local Flag file, then check the PRF National Flag file. If found, return the appropriate variable pointer.
+27 IF '$GET(DGDONE)
Begin DoDot:2
+28 SET DGIEN=$ORDER(^DGPF(26.15,"B",DGPRF,0))
+29 IF DGIEN
SET DGDONE=1
SET DGRSLT=DGIEN_";DGPF(26.15,"
End DoDot:2
End DoDot:1
+30 ;
+31 IF '$GET(DGDONE)
SET DGRSLT="-1;NOT FOUND"
+32 ;
+33 ; Check active status
+34 IF +$GET(DGRSLT)>0
Begin DoDot:1
+35 SET DGSTAT=$$GET1^DIQ($SELECT(DGRSLT[26.11:26.11,1:26.15),+DGRSLT,.02,"I")
+36 IF 'DGSTAT
SET DGRSLT="-1;NOT ACTIVE"
End DoDot:1
+37 ;
+38 QUIT $GET(DGRSLT)
+39 ;
ACTIVE(DGIEN,DGRANGE) ; Check if "active" during date range
+1 ; Input
+2 ; DGIEN - Pointer to PRF Assignment File (#26.13)
+3 ; DGRANGE - Array containg Start Date/End Date
+4 ;
+5 ; Output
+6 ; DGRSLT: 1 - "Active"
+7 ; 0 - "Not Active"
+8 ;
+9 NEW DGDT,DGX,DGACT,DGRSLT,DGACT2,DGPRE,DGPST,DGRSLT,DGCNT,DGDTPRE,DGDTPST
+10 ;
+11 SET DGRSLT=0
+12 ; Build array of actions fro processing
+13 SET (DGCNT,DGDT)=0
+14 FOR
SET DGDT=$ORDER(^DGPF(26.14,"C",DGIEN,DGDT))
if 'DGDT
QUIT
Begin DoDot:1
+15 SET DGX=$ORDER(^DGPF(26.14,"C",DGIEN,DGDT,0))
if 'DGX
QUIT
+16 SET DGACT(DGX)=$PIECE($GET(^DGPF(26.14,DGX,0)),U,3)_"^"_$PIECE($PIECE($GET(^DGPF(26.14,DGX,0)),U,2),".")
+17 SET DGCNT=DGCNT+1
End DoDot:1
+18 SET DGACT=DGCNT
+19 ;
+20 ; Check for last action of Entered in Error, if there is one, all previous actions are void
+21 ; Quit, returning inactive status
+22 SET DGX=$ORDER(DGACT(99999999),-1)
+23 IF $PIECE(DGACT(DGX),U)=5
SET DGRSLT=0
GOTO CHKQ
+24 ;
+25 ; Begin checking history file
+26 IF DGRANGE["A"
Begin DoDot:1
+27 ; If only one entry, should be NEW, process as active
IF DGACT=1
Begin DoDot:2
+28 SET DGX=$ORDER(DGACT(0))
+29 SET DGRSLT=$SELECT($PIECE(DGACT(DGX),U)=1:1,1:0)
End DoDot:2
+30 IF '$TEST
Begin DoDot:2
+31 SET DGX=$ORDER(DGACT(99999999),-1)
+32 ; Check last entry for EiE or Inact
IF "3,5"[$PIECE(DGACT(DGX),U)
SET DGRSLT=0
+33 IF '$TEST
SET DGRSLT=1
End DoDot:2
End DoDot:1
+34 IF '$TEST
Begin DoDot:1
+35 IF $PIECE($$ASGNDATE^DGPFAPIU(DGIEN),".")>DGRANGE("END")
SET DGRSLT=0
QUIT
+36 SET (DGACT2,DGX)=0
+37 FOR
SET DGX=$ORDER(DGACT(DGX))
if 'DGX
QUIT
Begin DoDot:2
+38 ; DG*971 Inclusive Range
IF $PIECE(DGACT(DGX),U,2)>DGRANGE("START")&($PIECE(DGACT(DGX),U,2)<=DGRANGE("END"))
SET DGACT2(DGX)=DGACT(DGX)
SET DGACT2=DGACT2+1
End DoDot:2
+39 ; If actions are found within the date range, process for active status.
+40 IF DGACT2>0
Begin DoDot:2
+41 SET DGX=0
FOR
SET DGX=$ORDER(DGACT2(DGX))
if 'DGX
QUIT
Begin DoDot:3
+42 SET DGRSLT=$SELECT("1,2,4"[$PIECE(DGACT2(DGX),U):1,1:0)
End DoDot:3
End DoDot:2
+43 ; If no action entry is found within the date range specified, then try to determine the status from
+44 ; the nearest action.
+45 IF '$TEST
Begin DoDot:2
+46 SET DGDTPRE=DGRANGE("START")_".999999"
+47 SET DGDTPRE=$ORDER(^DGPF(26.14,"C",DGIEN,DGDTPRE),-1)
+48 SET DGPRE=$SELECT(DGDTPRE>0:$ORDER(^DGPF(26.14,"C",DGIEN,DGDTPRE,0)),1:0)
+49 SET DGDTPST=$ORDER(^DGPF(26.14,"C",DGIEN,DGRANGE("END")))
+50 SET DGPST=$SELECT(DGDTPST>0:$ORDER(^DGPF(26.14,"C",DGIEN,DGDTPST,0)),1:0)
+51 SET DGRSLT=$SELECT("1,2,4"[$PIECE(DGACT(DGPRE),U):1,1:0)
+52 IF DGPST>0
IF $PIECE(DGACT(DGPST),U)="5"
SET DGRSLT=0
End DoDot:2
End DoDot:1
+53 ;
CHKQ ;
+1 ;
+2 QUIT +$GET(DGRSLT)
