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

DGRPEIS3.m

Go to the documentation of this file.
  1. DGRPEIS3 ;ALB/CAW,EG,ERC,BAJ,TDM - INCOME SCREENING DATA (CON'T) ; 5/26/10 2:03pm
  1. ;;5.3;Registration;**45,624,659,653,688,754**;Aug 13, 1993;Build 46
  1. ;
  1. HELP ; Display information when veteran's DOB is past the income year
  1. ;
  1. W !!,"Please return to screen 8 and check the veteran's effective date."
  1. W !,"The effective date was created based on the veteran's date of birth."
  1. W !,"You might also want to check the date of birth for this veteran."
  1. W ! S DIR(0)="E" D ^DIR K DIR W !
  1. Q
  1. ;
  1. WRT ; Write age statement
  1. Q:'$G(DGMTI)
  1. W !!,"This dependent is 18 years or older. To list this person as a dependent"
  1. W !,"they have to be:"
  1. W !," 1. An UNMARRIED child who is under the age of 18."
  1. W !," 2. Between the ages of 18 and 23 and attending school."
  1. W !," 3. An unmarried child over the age of 17 who became permanently"
  1. W !," incapable of self support before the age of 18."
  1. Q
  1. ;
  1. EDIT ;CALLED FROM ROUTINE DGRPEIS
  1. N DGEXIT,SSNV,SSNVL,SSNUM
  1. S DGEDDEP=1
  1. S DGFL=$G(DGFL)
  1. S DATE=$S($G(DATE):DATE,1:$$LYR^DGMTSCU1(DT))
  1. S X=$P(DGPREF,"^",2)
  1. S DGTYPE=$G(DGTYPE),DGTYPE=$S(DGTYPE']"":"S",DGTYPE="C":"C",DGTYPE="D":"D",1:"S")
  1. S DIE="^"_$P(X,";",2),DA=+X
  1. ;
  1. ; DG*5.3*653 ERC Pseudo SSN Reason changes
  1. ; DG*5.3*688 BAJ SSN Verification changes
  1. ;
  1. ; Retrieve SSN VERIFIED statusrequired
  1. S SSNVL=DIE_DA_",0)"
  1. S SSNUM=$P(@SSNVL,"^",9),SSNV=$P(@SSNVL,"^",11)
  1. ;
  1. ; Lock SSN if SSN is VERIFIED
  1. S DR=$S(SSNV=4:".01;.02;.03;S UPARROW=1",1:".01;.02;.03;.09;S UPARROW=1")
  1. S DGEXIT=0
  1. K DG,DQ D ^DIE I $D(DTOUT)!$D(DUOUT)!'$D(UPARROW) S DGFL=$S($D(DTOUT):-2,1:-1) S DGEXIT=1 D EDITQ Q
  1. I SSNV="V" W !,"SOCIAL SECURITY NUMBER "_SSNUM_" has been verified by SSA -- NO EDITING"
  1. ;
  1. ; changes to make Pseudo SSN Reason required - DG*5.3*653, ERC
  1. S DGEXIT=0 I $P($G(@(DIE_DA_",0)")),U,9)["P" D SSNREA(.DGEXIT) I DGEXIT=1 Q
  1. I DGTYPE="S" D
  1. . S DR="1.1;S UPARROW=1"
  1. . K DG,DQ D ^DIE I $D(DTOUT)!$D(DUOUT)!'$D(UPARROW) S DGFL=$S($D(DTOUT):-2,1:-1) S DGEXIT=1
  1. I DGEXIT=1 Q
  1. ;
  1. ; ; end SSN Verification & Pseudo SSN Reason changes
  1. ;
  1. S DOB=$P($G(@(DIE_DA_",0)")),U,3)
  1. ;
  1. N DGVADD,DGSADD,DGIPIEN,DGUQTLP,SPOUSE,DGFL,DGRPI
  1. S (DGVADD,DGSADD,DGIPIEN,DGUQTLP)=0
  1. S SPOUSE=$S(DGTYPE="S":1,1:0),DGFL=$G(DGFL)
  1. ;
  1. ; if veteran address is not USA, skip this ^DIR call
  1. I $$FORIEN^DGADDUTL($P($G(^DPT(DFN,.11)),U,10)) G FOREIGN
  1. ; Is spouse/dependent address same as patient address?
  1. K DIR
  1. S DIR(0)="YAO^^"
  1. S DIR("A")="STREET ADDRESS SAME AS PATIENT'S: "
  1. S DIR("B")="YES"
  1. S DIR("?")="Enter 'Y' if the "_$S(SPOUSE:"spouse",1:"child")_" has the same address as the patient, otherwise enter 'N'."
  1. D ^DIR
  1. S DGVADD=+Y
  1. K Y,DIR
  1. FOREIGN ;tag added for rejoining if country not USA
  1. S DGIPIEN=$$SPSCHK^DGRPEIS(DFN)
  1. I 'DGVADD,(DGTYPE'="S"),DGIPIEN D
  1. . K DIR,Y
  1. . S DIR(0)="YAO^^"
  1. . S DIR("A")="STREET ADDRESS SAME AS SPOUSE'S: "
  1. . S DIR("B")="YES"
  1. . S DIR("?")="Enter 'Y' if the child has the same address as the spouse, otherwise enter 'N'."
  1. . D ^DIR
  1. . S DGSADD=+Y
  1. . K Y,DIR
  1. ;
  1. ; If spouse/dependent address is same as patient's, set spouse/dep address
  1. I DGVADD!DGSADD D
  1. . I DGVADD D PATASET^DGRPEIS(DFN) ;*Set to Patient address
  1. . I DGSADD D SPSASET^DGRPEIS(DGIPIEN) ;*Set to Spouse address
  1. . N FLD,FDA S FLD=0 F S FLD=$O(ANS(FLD)) Q:'FLD D
  1. . . S FDA(408.13,DA_",",FLD)=ANS(FLD) K ANS(FLD)
  1. . D FILE^DIE("","FDA","")
  1. ;
  1. ;Spouse/dep address not same as patient/spouse address; prompt for it
  1. I 'DGVADD,'DGSADD D
  1. . S DR="1.2;S:X']"""" Y=1.5;1.3;S:X']"""" Y=1.5;1.4;1.5;1.6;1.7;1.8;S UPARROW=1"
  1. . K DG,DQ D ^DIE
  1. I $D(DTOUT)!$D(DUOUT)!'$D(UPARROW) S DGFL=$S($D(DTOUT):-2,1:-1) D EDITQ Q
  1. ;
  1. I DGTYPE'="S" K UPARROW S DIE="^DGPR(408.12,",DA=+DGPREF,DR=".02;S UPARROW=1" K DG,DQ D ^DIE I $D(DTOUT)!$D(DUOUT)!'$D(UPARROW) S DGFL=$S($D(DTOUT):-2,1:-1)
  1. S RELATION=$P($G(^DGPR(408.12,+DGPREF,0)),"^",2)
  1. S DGX=$O(^DGPR(408.12,+DGPREF,"E","AID","")),DGMIEN=$O(^(+DGX,0))
  1. EDACTDT I $G(^DGPR(408.12,+DGPREF,"E",+DGMIEN,0)) D G:$G(DGFL)<0 EDITQ
  1. . S (DGACT,Y)=+^(0) X ^DD("DD")
  1. . S DIR("B")=Y
  1. . D READ^DGRPEIS2
  1. . I -DGACT'=DGX W !,"Use 'Expand Dependent' option to change effective date." H 2 S DGFL=-1 Q
  1. . Q:$G(DGFL)<0
  1. . S DIE="^DGPR(408.12,"_+DGPREF_",""E"",",DA(1)=+DGPREF,DA=DGMIEN,DR=".01///"_DGACT
  1. . D ^DIE
  1. I DGTYPE="S" S X=+DGPREF D SETUP^DGRPEIS1
  1. K DGACT,DGMIEN,RELATION,DA,DIE,DR,UPARROW,DTOUT,DUOUT,DIRUT
  1. EDITQ K DA,DIE,DIRUT,DR,DTOUT,DUOUT
  1. Q
  1. ;
  1. SSNREA(DGEXIT) ;if SSN is pseudo Pseudo SSN Reason is required - DG*5.3*653
  1. N I,EXIT
  1. S EXIT=0
  1. F D Q:EXIT
  1. . S DR=$S(DIE["DGPR":.1,1:.0906)_";S UPARROW=1"
  1. . K DG,DQ D ^DIE I $D(DTOUT)!$D(DUOUT)!'$D(UPARROW) S DGFL=$S($D(DTOUT):-2,1:-1) S (EXIT,DGEXIT)=1 Q
  1. . I $P($G(@(DIE_DA_",0)")),U,10)']"" S EXIT=0 Q
  1. . S EXIT=1
  1. Q
  1. HELP1(DGISDT) ; Displays the help for the active/inactive prompt
  1. ;
  1. D CLEAR^VALM1
  1. W !,"Enter the date this person first became a dependent of the veteran."
  1. W !,"In the case of a spouse, this would be the date of marriage. For"
  1. W !,"a child, this would be the date of birth or date of adoption. For a"
  1. W !,"stepchild, this would be the date of marriage to the child's parent."
  1. W !!,"Date must be before DEC 31, "_DGISDT_" as dependents are collected for the"
  1. W !,"prior calendar year only."
  1. S VALMBCK="R"
  1. Q
  1. ;
  1. HELPDOB ; * Displays help for Date of Birth
  1. N DGRDVAR
  1. I X="?" D Q
  1. . W !?5,"Enter the date this dependent was born. The date must not be during the"
  1. . W !?5,"current calendar year. Only persons that were dependents before the"
  1. . W !?5,"current year may be entered.",!
  1. . I $G(DA) W !,"Enter RETURN to continue:" R DGRDVAR:DTIME W !
  1. ;
  1. W !?8,"Enter the date on which this relative was born. This information is"
  1. W !?8,"necessary for use in the income screening and means test portions of"
  1. W !?8,"MAS."
  1. W !!?8,"The date entered must not be during the current calendar year. That"
  1. W !?8,"is, it must be on or before December 31 or the prior calendar year."
  1. I $G(DA) W ! S DIR(0)="E" D ^DIR Q:+Y<1
  1. W !!?8,"The reason for this is that this data is used for collecting income"
  1. W !?8,"information for the purposes of comparing this data with the Internal"
  1. W !?8,"Revenue Service (IRS). Children born during the calendar year cannot"
  1. W !?8,"be entered until next year."
  1. I $G(DA) W !!,"Enter RETURN to continue:" R DGRDVAR:DTIME W !
  1. Q
  1. ;
  1. HELPMN ; * Displays help for Spouse Maiden Name
  1. W !?8,"Enter the spouse's maiden name in 'LAST,FIRST MIDDLE SUFFIX' format."
  1. W !?8,"Entry of the LAST name only is permitted and the comma may be omitted."
  1. W !?8,"If the response contains no comma, one will be appended to the value."
  1. W !?8,"Including the comma, the value must be at least 3 characters in length.",!
  1. Q
  1. ;
  1. HELPSA1 ; * Displays help for Street Address 1
  1. N DGRELTP
  1. S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1)
  1. W !,"If a "_DGRELTP_"'s name has been specified, enter the first line of"
  1. W !,"that person's street address [3-30 characters]; otherwise this field"
  1. W !,"may be left blank. This field cannot be deleted as long as a "_DGRELTP_"'s"
  1. W !,"name is on file."
  1. I $G(DA),(X="?") W !
  1. Q
  1. ;
  1. HELPSA2 ; * Displays help for Street Address 2
  1. N DGRELTP
  1. S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1)
  1. W !,"If a "_DGRELTP_"'s name has been specified, enter the second line of"
  1. W !,"that person's street address [3-30 characters]; otherwise this field"
  1. W !,"may be left blank. This field cannot be deleted as long as a "_DGRELTP_"'s"
  1. W !,"name is on file."
  1. I $G(DA),(X="?") W !
  1. Q
  1. ;
  1. HELPSA3 ; * Displays help for Street Address 3
  1. N DGRELTP
  1. S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1)
  1. W !,"If a "_DGRELTP_"'s name has been specified, enter the third line of"
  1. W !,"that person's street address [3-30 characters]; otherwise this field"
  1. W !,"may be left blank. This field cannot be deleted as long as a "_DGRELTP_"'s"
  1. W !,"name is on file."
  1. I $G(DA),(X="?") W !
  1. Q
  1. ;
  1. HELPCITY ; * Displays help for City
  1. N DGRELTP
  1. S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1)
  1. W !,"If a "_DGRELTP_"'s name has been specified, enter the city in which"
  1. W !,"that person resides [3-30 characters]; otherwise this field may be"
  1. W !,"left blank. This field cannot be deleted as long as a "_DGRELTP_"'s"
  1. W !,"name is on file."
  1. I $G(DA),(X="?") W !
  1. Q
  1. ;
  1. HELPSTAT ; * Displays help for the state
  1. N DGRELTP,DIRA,DGRDVAR,DDIOLARY
  1. S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1)
  1. S DDIOLARY(1)="If a "_DGRELTP_"'s name has been specified, select the state in which"
  1. S DDIOLARY(1,"F")="!"
  1. S DDIOLARY(2)="that person resides; otherwise this field may be left blank. This"
  1. S DDIOLARY(2,"F")="!"
  1. S DDIOLARY(3)="field cannot be deleted as long as a "_DGRELTP_"'s name is on file."
  1. S DDIOLARY(3,"F")="!"
  1. S DDIOLARY(4)=""
  1. S DDIOLARY(4,"F")="!"
  1. D EN^DDIOL(.DDIOLARY)
  1. ;
  1. Q:X="?"
  1. D EN^DDIOL("Enter RETURN to continue:","","!")
  1. R DGRDVAR:DTIME
  1. Q
  1. ;
  1. HELPZIP ; * Displays help for the Zip code
  1. N DGRELTP
  1. S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1)
  1. W !,"Answer with the 5 digit format (e.g. 12345) or the nine digit"
  1. W !,"format (e.g. 12345-6789 or 123456789). This is related to the"
  1. W !,DGRELTP_"'s address."
  1. I $G(DA),(X="?") W !
  1. Q
  1. HELPPHON ; * Displays help for the Phone number
  1. N DGRELTP
  1. S DGRELTP=$$RELTYPE^DGRPEIS2($G(DA),1)
  1. W !,"If a "_DGRELTP_"'s name has been specified, enter the "_DGRELTP_"'s"
  1. W !,"phone number [4-20 characters], otherwise this field may be left"
  1. W !,"blank. This field cannot be deleted as long as a "_DGRELTP_"'s"
  1. W !,"name is on file."
  1. I $G(DA),(X="?") W !
  1. Q