source: WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMUM3.m@ 623

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

initial load of WorldVistAEHR
File size: 3.2 KB
Line 
1IVMUM3 ;ALB/SEK,GTS - ADD NEW DEPENDENT TO PATIENT RELATIONS FILE ; 12 MAY 94
2 ;;2.0;INCOME VERIFICATION MATCH;**1,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 IVM spouses and
8 ; dependents. if only adding to 408.1275 and IVM 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 IVM 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 K DINUM
27 S DA(1)=DGPRI
28 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
29 ;
30 ; if can't create stub notify site & IVM Center
31 I DA'>0 D Q
32 .S (IVMTEXT(6),HLERR)="Can't create stub for file 408.1275"
33 .D ERRBULL^IVMPREC7,MAIL^IVMUFNC()
34 .S IVMFERR=""
35 ;
36 ;Set value of FILED BY IVM field : GTS - IVM*2*101
37 ;DGFIVM is YES when source of Means Test is DCD or IVM
38 N DGFIVM ;IVM*2*101
39 S DGFIVM=$$SRCOFMT^IVMCM3(DGMTI) ;IVM*2*101
40 ;
41 L +^DGPR(408.12,+DGPRI) S $P(^DGPR(408.12,DA(1),"E",DA,0),"^",2,4)=1_"^"_DGFIVM_"^"_DGMTI D IX1^DIK L -^DGPR(408.12,+DGPRI)
42 K IVMEFFDT,DA,DIC,DIK
43 ;
44 ; replace relationship in 408.12 with IVM relationship if different
45 ; and add both values to 408.41
46 ;
47 Q:IVMRELN=IVMRELO
48 S DA=DGPRI,DIE="^DGPR(408.12,",DR=".02////^S X=IVMRELN" D ^DIE K DA,DIE,DR
49 S DGMTYPT=1,DGMTACT="REL",DGMTSOLD=IVMRELO,DGMTSNEW=IVMRELN,DGDEPI=DGIPI,DGMTA=DGMTP
50 D SET^DGMTAUD
51 K DGDEPI,DGMTA,DGMTACT,DGMTSNEW,DGMTSOLD
52 Q
53 ;
54NEWPR ;Add entry to file #408.12
55 ;In - dgrp0nd 0 node of 408.12
56 ; ivmeffdt effective date of dependent
57 ; ivmreln IVM relationship
58 ;Out - dgpri ien of new 408.12 entry
59 ;
60 N DGFIVM ;IVM*2*101
61 S DGRP0ND=DFN_"^"_IVMRELN_"^"_+DGIPI_";DGPR(408.13,"
62 ;
63 K DINUM
64 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
65 ;
66 ; if can't create stub notify site & IVM Center
67 I DGPRI'>0 D Q
68 .S (IVMTEXT(6),HLERR)="Can't create stub for file 408.12"
69 .D ERRBULL^IVMPREC7,MAIL^IVMUFNC()
70 .S IVMFERR=""
71 ;
72 ;Set value of FILED BY IVM field : GTS - IVM*2*101
73 ;DGFIVM is YES when source of Means Test is DCD or IVM
74 S DGFIVM=$$SRCOFMT^IVMCM3(DGMTI)
75 ;
76 ;Create Patient Relation record : GTS - IVM*2*101 (DGFIVM replaces default of 1)
77 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_"^"_DGMTI D IX1^DIK L -^DGPR(408.12,+DGPRI)
78 K IVMEFFDT,DA,DIC,DIK
79 ;
80 ; to prevent the logic in IVMUM2 from matching a dependent sent from
81 ; the IVM Center (with no 408.12 ien) with this dependent, an entry
82 ; is made in array IVMAR. subscripts of this array is ien of 408.12
83 ; transmitted by the IVM Center or created or found by upload.
84 S IVMAR(DGPRI)=""
85 Q
Note: See TracBrowser for help on using the repository browser.