source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPEIS.m@ 812

Last change on this file since 812 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 7.4 KB
Line 
1DGRPEIS ;ALB/MIR,ERC - INCOME SCREENING DATA FOR EDIT ; 1/3/06 9:33am
2 ;;5.3;Registration;**10,45,108,624,653**;Aug 13, 1993;Build 2
3 ; Handles editing of dependent info
4 ; CHANGES TO THIS ROUTINE SHOULD BE COORDINATED WITH THE MEANS TEST
5 ; DEVELOPER. MANY CALLS IN THIS ROUTINE (ADD, EDIT, INACT, ETC.) ARE
6 ; CALLED FROM MEANS TEST OR ARE MIMICKED THERE.
7 ; In: DFN as IEN of PATIENT file
8 ; DGDR as string of items selected for editing
9 ;Out: DGFL as -2 if time-out, -1 if up-arrow
10EN S DGFL=0
11 S DGISDT=$$LYR^DGMTSCU1(DT)
12 S DGRP(0)=$G(^DPT(DFN,0)) D NEW^DGRPEIS1,GETREL^DGMTU11(DFN,"VSD",DGISDT)
13 I DGDR[801 D SPOUSE^DGRPEIS2 S DGPREF=$G(DGREL("S")) G Q:DGFL I DGSPFL D:DGPREF EDIT(DGPREF,"S") I 'DGPREF D ADD(DFN,"S")
14 K DGSPFL,DGPREF
15Q Q
16 ;
17ADD(DFN,DGTYPE,DGTSTDT) ; subroutine to add to files 408.12 & 408.13
18 ; In -- DFN as the IEN of file 2 for the vet
19 ; DGTYPE as C for mt children or D for all deps
20 ; S for spouse (default spouse)
21 ; DGTSTDT - optional test date
22 ;Out -- DGPRI as patient relation IEN
23 ; DGIPI as income person IEN
24 ; DGFL as -2 if time-out, -1 if '^', 0 otherwise
25 N ANS,DA,PROMPT,SPOUSE,TYPE,DGVADD,DGSKIPST,DGSADD,DGIPIEN,DGUQTLP
26 I '$D(DGTSTDT) N DGTSTDT S DGTSTDT=$S($D(DGMTDT):DGMTDT,1:DT)
27 S DGFL=$G(DGFL)
28 S DGTYPE=$G(DGTYPE),SPOUSE=$S(DGTYPE']"":1,DGTYPE="C":0,DGTYPE="D":0,1:1)
29 S DGFL=$G(DGFL),PROMPT="NAME^SEX^DATE OF BIRTH^^^^^^SSN^PS SSN REASON^MAIDEN NAME^STREET ADDRESS [LINE 1]^STREET ADDRESS [LINE 2]^STREET ADDRESS [LINE 3]^CITY^STATE^ZIP^PHONE NUMBER"
30 S TYPE=$S(SPOUSE:"SPOUSE'S ",DGTYPE="C":"CHILD'S ",1:"DEPENDENT'S ")
31 S DGSKIPST=0 ;* Skip Add 2 and 3 prompts when Add 1 or 2 not entered
32 S DGUQTLP=0
33 F DGRPI=.01:.01:.03,.09,.1,1.1:.1:1.8 D Q:DGVADD Q:DGSADD Q:DGUQTLP I DGFL Q
34 . S (DGSADD,DGVADD,DGIPIEN)=0
35 . ; Is spouse/dependent address same as patient address?
36 . I +DGRPI=1.2 DO
37 . . K DIR
38 . . S DIR(0)="YAO^^"
39 . . S DIR("A")=TYPE_"STREET ADDRESS SAME AS PATIENT'S: "
40 . . S DIR("B")="YES"
41 . . S:TYPE'="SPOUSE'S " DIR("?")="Enter 'Y' if the child/dependent has the same address and phone number as the patient, otherwise enter 'N'."
42 . . S:TYPE="SPOUSE'S " DIR("?")="Enter 'Y' if the spouse has the same address and phone number as the patient, otherwise enter 'N'."
43 . . D ^DIR
44 . . S DGVADD=+Y
45 . . K Y,DIR
46 . . S DGIPIEN=$$SPSCHK(DFN)
47 . . I 'DGVADD,(TYPE'="SPOUSE'S"),(DGIPIEN) DO
48 . . . K DIR,Y
49 . . . S DIR(0)="YAO^^"
50 . . . S DIR("A")=TYPE_"STREET ADDRESS SAME AS SPOUSE'S: "
51 . . . S DIR("B")="YES"
52 . . . S DIR("?")="Enter 'Y' if the child/dependent has the same address as the spouse, otherwise enter 'N'."
53 . . . D ^DIR
54 . . . S DGSADD=+Y
55 . . . K Y,DIR
56 . ;
57 . ; If spouse/dependent address is same as patient's set spouse/dep add.
58 . I DGVADD D PATASET(DFN) ;*Set to Patient address
59 . I DGSADD D SPSASET(DGIPIEN) ;*Set to Spouse address
60 . ;
61 . ; Spouse/dep address is not same as patient/spouse add, prompt add.
62 . I 'DGVADD,'DGSADD DO
63 . . K DIR S DIR(0)="408.13,"_DGRPI I DGRPI=.01 S DIR(0)=DIR(0)_"O"
64 . . I DGRPI=.02,SPOUSE S X=$P($G(^DPT(DFN,0)),"^",2) I X]"" S DIR("B")=$S(X="F":"MALE",1:"FEMALE") ; default spouse sex
65 . . S:DGRPI=.03 DIR(0)=DIR(0)_"^^"_"S %DT=""EP"" D ^%DT S X=Y K:($E(DGTSTDT,1,3)-1_1231)<X X"
66 . . S:+DGRPI<1 DIR("A")=TYPE_$P(PROMPT,"^",DGRPI*100)
67 . . S:+DGRPI>1 DIR("A")=TYPE_$P(PROMPT,"^",DGRPI*10)
68 . . I (+DGRPI'=1.1)!((+DGRPI=1.1)&(SPOUSE)&($G(ANS(.02))="F")) DO
69 . . . ;if .1, check to see if SSN is a pseudo, if yes, require Reason
70 . . . I DGRPI=.1 D REAS Q
71 . . . I (+DGRPI=1.3)!(+DGRPI=1.4) D:('DGSKIPST) ^DIR
72 . . . I (+DGRPI'=1.3)&(+DGRPI'=1.4) D ^DIR
73 . . . I $D(DTOUT)!$D(DUOUT) S:(DGRPI=.09)!((DGRPI>1.1)&(DGRPI<1.9)) DGUQTLP=1
74 . . . I $D(DTOUT)!$D(DUOUT) S DGFL=$S($D(DUOUT):$S((DGRPI>1.1)&(DGRPI<1.9):"",1:-1),1:-2) Q
75 . . . I DGRPI=.01,(Y']"") S DGFL=-1 Q
76 . . . S ANS(DGRPI)=Y
77 . . . I (+DGRPI=1.2),(ANS(1.2)']"") S DGSKIPST=1
78 . . . I (+DGRPI=1.3),(ANS(1.3)']"") S DGSKIPST=1
79 . . . I DGRPI=.03,$D(ANS(.03)) S X2=ANS(.03),X1=DT D ^%DTC I 'SPOUSE S AGE=(X/365.25) W ?62,"(AGE: "_$P(AGE,".")_")" I AGE>17 D WRT^DGRPEIS3
80 . . I DGRPI=.01,(Y']"") Q
81 I '$D(ANS(.01)) S DGFL=0 G ADDQ
82 I DGFL=-2!'$D(ANS(.09)) W !?3,*7,"Incomplete Entry...Deleted" G ADDQ
83 S DGRP0ND=ANS(.01)_"^"_ANS(.02)_"^"_ANS(.03)_"^^^^^^"_$G(ANS(.09))_"^"_$G(ANS(.1))
84 S DGRP1ND=$G(ANS(1.1))_"^"_$G(ANS(1.2))_"^"_$G(ANS(1.3))_"^"_$G(ANS(1.4))_"^"_$G(ANS(1.5))_"^"_$P($G(ANS(1.6)),"^",1)_"^"_$G(ANS(1.7))_"^"_$G(ANS(1.8))
85 D NEWIP^DGRPEIS1
86ADDQ K DGRP0ND,DGRP1ND,DGRPI,DIR,DIRUT,DTOUT,DUOUT
87 Q
88 ;
89PATASET(DFN) ;* Set the address equal to the patient's
90 ; Input: DFN - Patient file IEN and key to Patient Relation entries
91 ; Output: ANS array of dependents address
92 S ANS(1.2)=$P($G(^DPT(DFN,.11)),"^",1)
93 S ANS(1.3)=$P($G(^DPT(DFN,.11)),"^",2)
94 S ANS(1.4)=$P($G(^DPT(DFN,.11)),"^",3)
95 S ANS(1.5)=$P($G(^DPT(DFN,.11)),"^",4)
96 S ANS(1.6)=$P($G(^DPT(DFN,.11)),"^",5)
97 S ANS(1.7)=$P($G(^DPT(DFN,.11)),"^",12)
98 S ANS(1.8)=$P($G(^DPT(DFN,.13)),"^",1)
99 Q
100 ;
101SPSCHK(DFN) ;*Check for existence of active spouse
102 ; Input: DFN - Patient file IEN and key to Patient Relation entries
103 ; Output: IPIEN - Spouse IEN in 408.13
104 ; 0: no active spouse
105 N PRIEN,IPIEN,SPREDIEN,SPRED
106 S IPIEN=0
107 I $D(^DGPR(408.12,"B",DFN)) DO
108 . S PRIEN=""
109 . F S PRIEN=$O(^DGPR(408.12,"B",DFN,PRIEN)) Q:(+PRIEN=0) DO
110 . . I $D(^DG(408.11,$P(^DGPR(408.12,PRIEN,0),"^",2),0)) DO
111 . . . I $P(^DG(408.11,$P(^DGPR(408.12,PRIEN,0),"^",2),0),"^",1)="SPOUSE" DO
112 . . . . S SPRED=$O(^DGPR(408.12,PRIEN,"E","AID",""))
113 . . . . S:+SPRED'=0 SPREDIEN=$O(^DGPR(408.12,PRIEN,"E","AID",SPRED,""))
114 . . . . I +$P($G(^DGPR(408.12,PRIEN,"E",SPREDIEN,0)),"^",2)=1 S IPIEN=$P($P(^DGPR(408.12,PRIEN,0),"^",3),";",1)
115 Q IPIEN
116 ;
117SPSASET(IPIEN) ;* Set the address equal to the patient's spouse address
118 ; Input: IPIEN - Spouse IEN in 408.13
119 ; Output: ANS array of Childs address
120 ;
121 S ANS(1.2)=$P($G(^DGPR(408.13,IPIEN,1)),"^",2)
122 S ANS(1.3)=$P($G(^DGPR(408.13,IPIEN,1)),"^",3)
123 S ANS(1.4)=$P($G(^DGPR(408.13,IPIEN,1)),"^",4)
124 S ANS(1.5)=$P($G(^DGPR(408.13,IPIEN,1)),"^",5)
125 S ANS(1.6)=$P($G(^DGPR(408.13,IPIEN,1)),"^",6)
126 S ANS(1.7)=$P($G(^DGPR(408.13,IPIEN,1)),"^",7)
127 S ANS(1.8)=$P($G(^DGPR(408.13,IPIEN,1)),"^",8)
128 Q
129 ;
130INACT ; prompt to inactivate a patient relation
131 ; Input -- DGREL("D") array of dependents
132 ; DGDEP as number of deps (from GETREL call)
133 N ACT,DGDT,IEN,X
134 S DGFL=$G(DGFL)
135 I 'DGDEP W !!,"No dependents to inactivate!" Q
136 W !!,"Enter a number 1-",DGDEP," to indicate the dependent you wish to inactivate: " R X:DTIME
137 I '$T S DGFL=-2 Q
138 I X["^" S DGFL=-1 Q
139 I X']"" Q
140 I X["?" W !!,"Enter a number 1-",DGDEP," indicating the number of the dependent you wish to inactivate" G INACT
141 I $D(DGREL("D",X)) S X=DGREL("D",X) D SETUP^DGRPEIS1 Q ; check for IVM dependents
142 S X=$G(DGREL("C",X)) I 'X G INACT ; check for MT deps
143 D SETUP^DGRPEIS1
144 Q
145EDIT(DGPREF,DGTYPE,DATE) ; edit demographic data for a dep
146 ; Input -- DGPREF as returned by GETREL^DGMTU11 for dep to edit
147 ; DGTYPE as D if all deps or C if MT children only
148 ; S for spouse (optional - spouse if not defined)
149 ; DATE [optional] as income screening year/default= last yr
150 ; Output -- DGFL as -2 if timeout, -1 if '^', or 0 o/w
151 N DOB,DGACT,RELATION,UPARROW,X,Y,DGEDDEP
152 D EDIT^DGRPEIS3
153 Q
154REAS ;require a Pseudo SSN Reason if the SSN is a Pseudo - DG*5.3*653 ERC
155 Q:ANS(.09)'["P"
156 S DIR(0)="408.13,.1^^"
157 D ^DIR
158 I $D(DUOUT) S DGFL=-2 Q
159 I $D(DTOUT)!($D(DIRUT)) W !!,"Pseudo SSN Reason Required if the SSN is Pseudo." G REAS
160 ;I $D(DUOUT) S DGFL=-2 Q
161 S ANS(.1)=Y
162 Q
Note: See TracBrowser for help on using the repository browser.