- 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 Feb 19, 2025@00:09:31 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)