Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGFFP01

DGFFP01.m

Go to the documentation of this file.
  1. DGFFP01 ; ALB/SCK - FUGITIVE FELON PROGRAM ROUTINE ; 11/08/2002
  1. ;;5.3;Registration;**485**;Aug 13, 1993
  1. ;
  1. Q
  1. ;
  1. GETPAT(ACTION) ; Retrieve patient name
  1. N DIR,Y,X,DIRUT,RSLT
  1. ;
  1. S ACTION=$G(ACTION)
  1. S RSLT=-1
  1. S DIR(0)="PAO^2:EMZ"
  1. S DIR("A")="Select Patient: "
  1. S DIR("?")="Enter the name of a patient to update the Fugitive Felon Flag for."
  1. I ACTION S DIR("S")="I $P($G(^DPT(Y,""FFP"")),U,1)=1"
  1. D ^DIR K DIR
  1. ;
  1. I $D(DIRUT)
  1. E S:+Y RSLT=Y
  1. Q RSLT
  1. ;
  1. CONT() ; Query to continue processing
  1. N DIR,Y,X
  1. ;
  1. S DIR(0)="YA"
  1. S DIR("A",1)=""
  1. S DIR("A")="Process another felon entry? "
  1. S DIR("B")="YES"
  1. S DIR("?")="Enter 'YES' to continue processing, 'NO' to exit."
  1. D ^DIR K DIR
  1. Q +$G(Y)
  1. ;
  1. CONFIRM(DGACT,DGPAT) ; Query to confirm set/clear the fugitive felon flag
  1. N DIR,DIRUT,X,Y,DGABRT
  1. ;
  1. I "S"[DGACT D I $G(DGABRT) Q 0
  1. . I $D(^DPT("AXFFP",1,+DGPAT)) D Q
  1. . . W !?2,"The Fugitive Felon Flag is already set..."
  1. . . S DGABRT=1
  1. . S DIR("A",1)=""
  1. . S DIR("A",2)=" >> This will set the Fugitive Felon Flag for "_$P(DGPAT,U,2)_"."
  1. . S DIR("A")=" >> Continue with setting the flag? "
  1. . S DIR("?")="Enter 'YES' to set the flag, 'NO' to skip."
  1. ;
  1. I "C"[DGACT D
  1. . S DIR("A",1)=""
  1. . S DIR("A",2)=" >> This will clear the Fugitive Felon Flag for "_$P(DGPAT,U,2)_"."
  1. . S DIR("A")=" >> Continue with clearing the flag? "
  1. . S DIR("?")="Enter 'YES' to set the flag, 'NO' to skip."
  1. ;
  1. S DIR(0)="YA",DIR("B")="NO"
  1. D ^DIR K DIR
  1. Q $G(Y)
  1. ;
  1. SETFLAG ; Set the Fugitive Felon Flag
  1. N DGPAT,DGFDA,DGERR
  1. ;
  1. SET1 S DGPAT=$$GETPAT
  1. I +DGPAT<0 G QSET
  1. I $$CONFIRM("S",DGPAT) D
  1. . S DGFDA(1,2,+DGPAT_",",1100.01)=1
  1. . D FILE^DIE("","DGFDA(1)","DGERR")
  1. . I $D(DGERR) D MSG^DIALOG("EAW","",70,5,"DGERR")
  1. ;
  1. I '$$CONT G QSET
  1. G SET1
  1. QSET Q
  1. ;
  1. CLRFLAG ; Clear the Fugitive Felon Flag
  1. N DGPAT,DGFDA,DGERR
  1. ;
  1. CLR1 S DGPAT=$$GETPAT(1)
  1. I +DGPAT<0 G QCLR
  1. I $$CONFIRM("C",DGPAT) D
  1. . S DGFDA(1,2,+DGPAT_",",1100.01)="@"
  1. . D FILE^DIE("","DGFDA(1)","DGERR")
  1. . I $D(DGERR) D MSG^DIALOG("EAW","",70,5,"DGERR")
  1. ;
  1. I '$$CONT G QCLR
  1. G CLR1
  1. QCLR Q
  1. ;
  1. DD(DFN) ; CALLED BY AUFFP X-REF ON THE FUGITIVE FELON FLAG FIELD
  1. ; #1100.01 IN THE PATIENT FILE #2.
  1. ;
  1. ; This procedure will set the following fields:
  1. ; FFF ENTERED BY, Field #1100.02
  1. ; FFF DATE ENTERED, Field #1100.03
  1. ; FFF REMOVED BY, Field 1100.04
  1. ; FFF DATE REMOVED,, Field 1100.05
  1. ; FFF REMOVAL REMARKS, Field 1100.09
  1. ;
  1. ; Check Input
  1. I +$G(DFN),$D(^DPT(DFN,0))
  1. E Q
  1. ;
  1. N DGFDA,DGIEN,DGOLD
  1. ;
  1. S DGIEN=DFN_","
  1. S DGOLD=$G(^DPT(DFN,"FFP"))
  1. I +DGOLD D
  1. . I $P(DGOLD,"^",2)>0
  1. . E D
  1. . . S DGFDA(1,2,DGIEN,1100.02)=DUZ
  1. . . S DGFDA(1,2,DGIEN,1100.03)=$$NOW^XLFDT
  1. . I $P(DGOLD,"^",4)>0 D
  1. . . S DGFDA(1,2,DGIEN,1100.04)="@"
  1. . . S DGFDA(1,2,DGIEN,1100.05)="@"
  1. . . S DGFDA(1,2,DGIEN,1100.09)="@"
  1. E D
  1. . ;S DGFDA(1,2,DGIEN,1100.02)="@"
  1. . ;S DGFDA(1,2,DGIEN,1100.03)="@"
  1. . S DGFDA(1,2,DGIEN,1100.04)=DUZ
  1. . S DGFDA(1,2,DGIEN,1100.05)=$$NOW^XLFDT
  1. . S DGFDA(1,2,DGIEN,1100.09)=$$RMRK
  1. ;
  1. D:$D(DGFDA) FILE^DIE("","DGFDA(1)")
  1. Q
  1. ;
  1. RMRK() ;
  1. N DIR
  1. ;
  1. AGN S DIR(0)="FA",DIR("A",1)=" >> Enter a brief remark on why this flag is being cleared."
  1. S DIR("A",2)=" >> This is a required field."
  1. S DIR("A")=" --> "
  1. S DIR("?",1)=" Remark must be between 2-80 characters. Please be brief"
  1. S DIR("?")=" This field is required when clearing the Fugitive Felon Flag"
  1. D ^DIR K DIR
  1. I $L(Y)>80!($L(Y)<2) K Y G AGN
  1. Q $G(Y)