source: WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMCM3.m@ 1800

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

initial load of WorldVistAEHR
File size: 4.6 KB
Line 
1IVMCM3 ;ALB/SEK - ADD NEW DCD DEPENDENT TO PATIENT RELATION FILE ; 25-APR-95
2 ;;2.0;INCOME VERIFICATION MATCH;**17,101**;21-OCT-94;Build 5
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EN ; this routine will add entries for new dependents to PATIENT
6 ; RELATION file-408.12 (including 408.1275) or will add new entries
7 ; to effective date multiple (408.1275) for all DCD spouses and
8 ; dependents. if only adding to 408.1275 and DCD relationship is
9 ; different then VAMC relationship, change in 408.12 and add to
10 ; MEANS TEST CHANGES file (408.41).
11 ;
12 ; input dfn ien of file #2
13 ; dgipi 408.13 ien
14 ; dgmti 408.31 ien
15 ; dgpri 408.12 ien
16 ; ivmeffdt effective (dependent) date of spouse/dependent
17 ; ivmreln DCD relationship
18 ; ivmrelo VAMC relationship
19 ; ivmseg ZDP segment of spouse/dependent
20 ;
21 ;
22 I IVMFLG2 G NEWPR
23 ;
24 ; add new entry to 408.1275
25 ;
26 N X,Y
27 K DINUM
28 S DA(1)=DGPRI
29 S (DIK,DIC)="^DGPR(408.12,DA(1),""E"",",DIC(0)="L",DLAYGO=408.1275,X=IVMEFFDT K DD,DO D FILE^DICN S DA=+Y K DLAYGO
30 ;
31 ; if can't create stub notify site & IVM Center
32 I DA'>0 D Q
33 .S (IVMTEXT(6))="Can't create stub for file 408.1275"
34 .D PROB^IVMCMC(IVMTEXT(6))
35 .D ERRBULL^IVMPREC7,MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS")
36 .S IVMFERR=""
37 ;
38 ;Set value of FILED BY IVM field : GTS - IVM*2*101
39 ;DGFIVM is YES when source of Means Test is DCD or IVM
40 N DGFIVM ;IVM*2*101
41 S DGFIVM=$$SRCOFMT(DGMTI) ;IVM*2*101
42 ;
43 L +^DGPR(408.12,+DGPRI) S $P(^DGPR(408.12,DA(1),"E",DA,0),"^",2,4)=1_"^"_DGFIVM_$S(IVMTYPE=3:"",1:"^"_DGMTI) D IX1^DIK L -^DGPR(408.12,+DGPRI)
44 K IVMEFFDT,DA,DIC,DIK
45 ;
46 ; replace relationship in 408.12 with DCD relationship if different
47 ; and add both values to 408.41
48 ;
49 Q:IVMRELN=IVMRELO
50 S DA=DGPRI,DIE="^DGPR(408.12,",DR=".02////^S X=IVMRELN" D ^DIE K DA,DIE,DR
51 S DGMTYPT=$S(IVMTYPE=3:"",1:IVMTYPE),DGMTACT="REL",DGMTSOLD=IVMRELO,DGMTSNEW=IVMRELN,DGDEPI=DGIPI
52 I IVMMTIEN S DGMTA=$G(^DGMT(408.31,IVMMTIEN,0))
53 S $P(DGMTA,"^",2)=DFN
54 D SET^DGMTAUD
55 K DGDEPI,DGMTA,DGMTACT,DGMTSNEW,DGMTSOLD
56 Q
57 ;
58NEWPR ;Add entry to file #408.12
59 ;In - dgrp0nd 0 node of 408.12
60 ; ivmeffdt effective date of dependent
61 ; ivmreln DCD relationship
62 ;Out - dgpri ien of new 408.12 entry
63 ;
64 S DGRP0ND=DFN_"^"_IVMRELN_"^"_+DGIPI_";DGPR(408.13,"
65 ;
66 N DGFIVM ;IVM*2*101
67 N X,Y
68 K DINUM
69 S (DIK,DIC)="^DGPR(408.12,",DIC(0)="L",DLAYGO=408.12,X=+DGRP0ND K DD,DO D FILE^DICN S (DGPRI,DA)=+Y K DLAYGO
70 ;
71 ; if can't create stub notify site & IVM Center
72 I DGPRI'>0 D Q
73 .S (IVMTEXT(6))="Can't create stub for file 408.12"
74 .D PROB^IVMCMC(IVMTEXT(6))
75 .D ERRBULL^IVMPREC7,MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS")
76 .S IVMFERR=""
77 ;
78 ;Set value of FILED BY IVM field : GTS - IVM*2*101
79 ;DGFIVM is YES when source of Means Test is DCD or IVM
80 S DGFIVM=$$SRCOFMT(DGMTI)
81 ;
82 ;Create Patient Relation record : GTS - IVM*2*101 (DGFIVM replaces default of 1)
83 L +^DGPR(408.12,+DGPRI) S ^DGPR(408.12,+DGPRI,0)=DGRP0ND,^DGPR(408.12,+DGPRI,"E",0)="^408.1275D^1^1",^(1,0)=IVMEFFDT_"^1^"_DGFIVM_$S(IVMTYPE=3:"",1:"^"_DGMTI) D IX1^DIK L -^DGPR(408.12,+DGPRI)
84 K IVMEFFDT,DA,DIC,DIK
85 ;
86 ; to prevent the logic in IVMCM2 from matching a dependent sent from
87 ; the IVM Center (with no 408.12 ien) with this dependent, an entry
88 ; is made in array IVMAR. subscripts of this array is ien of 408.12
89 ; transmitted by the IVM Center or created or found by upload.
90 S IVMAR(DGPRI)=""
91 Q
92 ;
93NEWVET ; if no entry in file #408.12 for vet add
94 N DGRPDOB,DA,DIC,DIK,X,Y
95 S DGPRI=$O(^DGPR(408.12,"C",DFN_";DPT(",0))
96 I '$D(^DGPR(408.12,+DGPRI,0)) S DGRP0ND=DFN_"^"_1_"^"_DFN_";DPT(",DGRPDOB=$P($G(^DPT(+DFN,0)),"^",3) D
97 .K DINUM
98 .S (DIK,DIC)="^DGPR(408.12,",DIC(0)="L",DLAYGO=408.12,X=+DGRP0ND K DD,DO D FILE^DICN S (DGPRI,DA)=+Y K DLAYGO
99 .;
100 .; if can't create stub notify site & IVM Center
101 .I DGPRI'>0 D Q
102 ..S (IVMTEXT(6))="Can't create stub for file 408.12"
103 ..D PROB^IVMCMC(IVMTEXT(6))
104 ..D ERRBULL^IVMPREC7,MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS")
105 ..S IVMFERR=""
106 .L +^DGPR(408.12,+DGPRI) S ^DGPR(408.12,+DGPRI,0)=DGRP0ND,^DGPR(408.12,+DGPRI,"E",0)="^408.1275D^1^1",^(1,0)=DGRPDOB_"^1^1"_$S(IVMTYPE=3:"",1:"^"_DGMTI) D IX1^DIK L -^DGPR(408.12,+DGPRI)
107 ;
108 Q
109 ;
110SRCOFMT(DGMTI) ;Define value of FILED BY IVM field : GTS - IVM*2*101
111 ;
112 ; Input: DGMTI - IEN for related Annual Means Test record (408.31)
113 ; Output: DGFIVM - Null when Source of Means Test is Other Facility or VAMC
114 ; - 1 when source of Means Test is DCD or IVM
115 N DGFIVM
116 S:(+$G(DGMTI)'>0) DGFIVM=""
117 I +$G(DGMTI)>0 DO
118 . N DGSOURCE
119 . S DGSOURCE=$P($G(^DGMT(408.31,DGMTI,0)),"^",23)
120 . I (DGSOURCE=1)!(DGSOURCE=4) S DGFIVM=""
121 . I (DGSOURCE=2)!(DGSOURCE=3) S DGFIVM=1
122 Q DGFIVM
Note: See TracBrowser for help on using the repository browser.