DGFFP01 ; ALB/SCK - FUGITIVE FELON PROGRAM ROUTINE ; 11/08/2002
;;5.3;Registration;**485**;Aug 13, 1993
;
Q
;
GETPAT(ACTION) ; Retrieve patient name
N DIR,Y,X,DIRUT,RSLT
;
S ACTION=$G(ACTION)
S RSLT=-1
S DIR(0)="PAO^2:EMZ"
S DIR("A")="Select Patient: "
S DIR("?")="Enter the name of a patient to update the Fugitive Felon Flag for."
I ACTION S DIR("S")="I $P($G(^DPT(Y,""FFP"")),U,1)=1"
D ^DIR K DIR
;
I $D(DIRUT)
E S:+Y RSLT=Y
Q RSLT
;
CONT() ; Query to continue processing
N DIR,Y,X
;
S DIR(0)="YA"
S DIR("A",1)=""
S DIR("A")="Process another felon entry? "
S DIR("B")="YES"
S DIR("?")="Enter 'YES' to continue processing, 'NO' to exit."
D ^DIR K DIR
Q +$G(Y)
;
CONFIRM(DGACT,DGPAT) ; Query to confirm set/clear the fugitive felon flag
N DIR,DIRUT,X,Y,DGABRT
;
I "S"[DGACT D I $G(DGABRT) Q 0
. I $D(^DPT("AXFFP",1,+DGPAT)) D Q
. . W !?2,"The Fugitive Felon Flag is already set..."
. . S DGABRT=1
. S DIR("A",1)=""
. S DIR("A",2)=" >> This will set the Fugitive Felon Flag for "_$P(DGPAT,U,2)_"."
. S DIR("A")=" >> Continue with setting the flag? "
. S DIR("?")="Enter 'YES' to set the flag, 'NO' to skip."
;
I "C"[DGACT D
. S DIR("A",1)=""
. S DIR("A",2)=" >> This will clear the Fugitive Felon Flag for "_$P(DGPAT,U,2)_"."
. S DIR("A")=" >> Continue with clearing the flag? "
. S DIR("?")="Enter 'YES' to set the flag, 'NO' to skip."
;
S DIR(0)="YA",DIR("B")="NO"
D ^DIR K DIR
Q $G(Y)
;
SETFLAG ; Set the Fugitive Felon Flag
N DGPAT,DGFDA,DGERR
;
SET1 S DGPAT=$$GETPAT
I +DGPAT<0 G QSET
I $$CONFIRM("S",DGPAT) D
. S DGFDA(1,2,+DGPAT_",",1100.01)=1
. D FILE^DIE("","DGFDA(1)","DGERR")
. I $D(DGERR) D MSG^DIALOG("EAW","",70,5,"DGERR")
;
I '$$CONT G QSET
G SET1
QSET Q
;
CLRFLAG ; Clear the Fugitive Felon Flag
N DGPAT,DGFDA,DGERR
;
CLR1 S DGPAT=$$GETPAT(1)
I +DGPAT<0 G QCLR
I $$CONFIRM("C",DGPAT) D
. S DGFDA(1,2,+DGPAT_",",1100.01)="@"
. D FILE^DIE("","DGFDA(1)","DGERR")
. I $D(DGERR) D MSG^DIALOG("EAW","",70,5,"DGERR")
;
I '$$CONT G QCLR
G CLR1
QCLR Q
;
DD(DFN) ; CALLED BY AUFFP X-REF ON THE FUGITIVE FELON FLAG FIELD
; #1100.01 IN THE PATIENT FILE #2.
;
; This procedure will set the following fields:
; FFF ENTERED BY, Field #1100.02
; FFF DATE ENTERED, Field #1100.03
; FFF REMOVED BY, Field 1100.04
; FFF DATE REMOVED,, Field 1100.05
; FFF REMOVAL REMARKS, Field 1100.09
;
; Check Input
I +$G(DFN),$D(^DPT(DFN,0))
E Q
;
N DGFDA,DGIEN,DGOLD
;
S DGIEN=DFN_","
S DGOLD=$G(^DPT(DFN,"FFP"))
I +DGOLD D
. I $P(DGOLD,"^",2)>0
. E D
. . S DGFDA(1,2,DGIEN,1100.02)=DUZ
. . S DGFDA(1,2,DGIEN,1100.03)=$$NOW^XLFDT
. I $P(DGOLD,"^",4)>0 D
. . S DGFDA(1,2,DGIEN,1100.04)="@"
. . S DGFDA(1,2,DGIEN,1100.05)="@"
. . S DGFDA(1,2,DGIEN,1100.09)="@"
E D
. ;S DGFDA(1,2,DGIEN,1100.02)="@"
. ;S DGFDA(1,2,DGIEN,1100.03)="@"
. S DGFDA(1,2,DGIEN,1100.04)=DUZ
. S DGFDA(1,2,DGIEN,1100.05)=$$NOW^XLFDT
. S DGFDA(1,2,DGIEN,1100.09)=$$RMRK
;
D:$D(DGFDA) FILE^DIE("","DGFDA(1)")
Q
;
RMRK() ;
N DIR
;
AGN S DIR(0)="FA",DIR("A",1)=" >> Enter a brief remark on why this flag is being cleared."
S DIR("A",2)=" >> This is a required field."
S DIR("A")=" --> "
S DIR("?",1)=" Remark must be between 2-80 characters. Please be brief"
S DIR("?")=" This field is required when clearing the Fugitive Felon Flag"
D ^DIR K DIR
I $L(Y)>80!($L(Y)<2) K Y G AGN
Q $G(Y)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGFFP01 3511 printed Sep 23, 2025@20:19:20 Page 2
DGFFP01 ; ALB/SCK - FUGITIVE FELON PROGRAM ROUTINE ; 11/08/2002
+1 ;;5.3;Registration;**485**;Aug 13, 1993
+2 ;
+3 QUIT
+4 ;
GETPAT(ACTION) ; Retrieve patient name
+1 NEW DIR,Y,X,DIRUT,RSLT
+2 ;
+3 SET ACTION=$GET(ACTION)
+4 SET RSLT=-1
+5 SET DIR(0)="PAO^2:EMZ"
+6 SET DIR("A")="Select Patient: "
+7 SET DIR("?")="Enter the name of a patient to update the Fugitive Felon Flag for."
+8 IF ACTION
SET DIR("S")="I $P($G(^DPT(Y,""FFP"")),U,1)=1"
+9 DO ^DIR
KILL DIR
+10 ;
+11 IF $DATA(DIRUT)
+12 IF '$TEST
if +Y
SET RSLT=Y
+13 QUIT RSLT
+14 ;
CONT() ; Query to continue processing
+1 NEW DIR,Y,X
+2 ;
+3 SET DIR(0)="YA"
+4 SET DIR("A",1)=""
+5 SET DIR("A")="Process another felon entry? "
+6 SET DIR("B")="YES"
+7 SET DIR("?")="Enter 'YES' to continue processing, 'NO' to exit."
+8 DO ^DIR
KILL DIR
+9 QUIT +$GET(Y)
+10 ;
CONFIRM(DGACT,DGPAT) ; Query to confirm set/clear the fugitive felon flag
+1 NEW DIR,DIRUT,X,Y,DGABRT
+2 ;
+3 IF "S"[DGACT
Begin DoDot:1
+4 IF $DATA(^DPT("AXFFP",1,+DGPAT))
Begin DoDot:2
+5 WRITE !?2,"The Fugitive Felon Flag is already set..."
+6 SET DGABRT=1
End DoDot:2
QUIT
+7 SET DIR("A",1)=""
+8 SET DIR("A",2)=" >> This will set the Fugitive Felon Flag for "_$PIECE(DGPAT,U,2)_"."
+9 SET DIR("A")=" >> Continue with setting the flag? "
+10 SET DIR("?")="Enter 'YES' to set the flag, 'NO' to skip."
End DoDot:1
IF $GET(DGABRT)
QUIT 0
+11 ;
+12 IF "C"[DGACT
Begin DoDot:1
+13 SET DIR("A",1)=""
+14 SET DIR("A",2)=" >> This will clear the Fugitive Felon Flag for "_$PIECE(DGPAT,U,2)_"."
+15 SET DIR("A")=" >> Continue with clearing the flag? "
+16 SET DIR("?")="Enter 'YES' to set the flag, 'NO' to skip."
End DoDot:1
+17 ;
+18 SET DIR(0)="YA"
SET DIR("B")="NO"
+19 DO ^DIR
KILL DIR
+20 QUIT $GET(Y)
+21 ;
SETFLAG ; Set the Fugitive Felon Flag
+1 NEW DGPAT,DGFDA,DGERR
+2 ;
SET1 SET DGPAT=$$GETPAT
+1 IF +DGPAT<0
GOTO QSET
+2 IF $$CONFIRM("S",DGPAT)
Begin DoDot:1
+3 SET DGFDA(1,2,+DGPAT_",",1100.01)=1
+4 DO FILE^DIE("","DGFDA(1)","DGERR")
+5 IF $DATA(DGERR)
DO MSG^DIALOG("EAW","",70,5,"DGERR")
End DoDot:1
+6 ;
+7 IF '$$CONT
GOTO QSET
+8 GOTO SET1
QSET QUIT
+1 ;
CLRFLAG ; Clear the Fugitive Felon Flag
+1 NEW DGPAT,DGFDA,DGERR
+2 ;
CLR1 SET DGPAT=$$GETPAT(1)
+1 IF +DGPAT<0
GOTO QCLR
+2 IF $$CONFIRM("C",DGPAT)
Begin DoDot:1
+3 SET DGFDA(1,2,+DGPAT_",",1100.01)="@"
+4 DO FILE^DIE("","DGFDA(1)","DGERR")
+5 IF $DATA(DGERR)
DO MSG^DIALOG("EAW","",70,5,"DGERR")
End DoDot:1
+6 ;
+7 IF '$$CONT
GOTO QCLR
+8 GOTO CLR1
QCLR QUIT
+1 ;
DD(DFN) ; CALLED BY AUFFP X-REF ON THE FUGITIVE FELON FLAG FIELD
+1 ; #1100.01 IN THE PATIENT FILE #2.
+2 ;
+3 ; This procedure will set the following fields:
+4 ; FFF ENTERED BY, Field #1100.02
+5 ; FFF DATE ENTERED, Field #1100.03
+6 ; FFF REMOVED BY, Field 1100.04
+7 ; FFF DATE REMOVED,, Field 1100.05
+8 ; FFF REMOVAL REMARKS, Field 1100.09
+9 ;
+10 ; Check Input
+11 IF +$GET(DFN)
IF $DATA(^DPT(DFN,0))
+12 IF '$TEST
QUIT
+13 ;
+14 NEW DGFDA,DGIEN,DGOLD
+15 ;
+16 SET DGIEN=DFN_","
+17 SET DGOLD=$GET(^DPT(DFN,"FFP"))
+18 IF +DGOLD
Begin DoDot:1
+19 IF $PIECE(DGOLD,"^",2)>0
+20 IF '$TEST
Begin DoDot:2
+21 SET DGFDA(1,2,DGIEN,1100.02)=DUZ
+22 SET DGFDA(1,2,DGIEN,1100.03)=$$NOW^XLFDT
End DoDot:2
+23 IF $PIECE(DGOLD,"^",4)>0
Begin DoDot:2
+24 SET DGFDA(1,2,DGIEN,1100.04)="@"
+25 SET DGFDA(1,2,DGIEN,1100.05)="@"
+26 SET DGFDA(1,2,DGIEN,1100.09)="@"
End DoDot:2
End DoDot:1
+27 IF '$TEST
Begin DoDot:1
+28 ;S DGFDA(1,2,DGIEN,1100.02)="@"
+29 ;S DGFDA(1,2,DGIEN,1100.03)="@"
+30 SET DGFDA(1,2,DGIEN,1100.04)=DUZ
+31 SET DGFDA(1,2,DGIEN,1100.05)=$$NOW^XLFDT
+32 SET DGFDA(1,2,DGIEN,1100.09)=$$RMRK
End DoDot:1
+33 ;
+34 if $DATA(DGFDA)
DO FILE^DIE("","DGFDA(1)")
+35 QUIT
+36 ;
RMRK() ;
+1 NEW DIR
+2 ;
AGN SET DIR(0)="FA"
SET DIR("A",1)=" >> Enter a brief remark on why this flag is being cleared."
+1 SET DIR("A",2)=" >> This is a required field."
+2 SET DIR("A")=" --> "
+3 SET DIR("?",1)=" Remark must be between 2-80 characters. Please be brief"
+4 SET DIR("?")=" This field is required when clearing the Fugitive Felon Flag"
+5 DO ^DIR
KILL DIR
+6 IF $LENGTH(Y)>80!($LENGTH(Y)<2)
KILL Y
GOTO AGN
+7 QUIT $GET(Y)
