1 | IVMUM8 ;ALB/SEK - DELETE IVM MEANS TEST (CON'T) ; 13 JAN 94
|
---|
2 | ;;2.0;INCOME VERIFICATION MATCH;**1,17**;21-OCT-94
|
---|
3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
---|
4 | ;
|
---|
5 | EN ; change demo data in 408.12 & 408.13 back to VAMC values
|
---|
6 | ; ivm12 408.12 ien
|
---|
7 | ; ivm13 408.13 ien
|
---|
8 | ; ivmmtien 408.31 ien
|
---|
9 | ;
|
---|
10 | ; note: 408.13 fields were added to 408.41 before 408.12 field
|
---|
11 | ;
|
---|
12 | K DR S IVM41=0
|
---|
13 | F S IVM41=$O(^DGMT(408.41,"D",IVMMTIEN,IVM41)) Q:'IVM41 D
|
---|
14 | .S IVM411=$G(^DGMT(408.41,+IVM41,0))
|
---|
15 | .Q:$P(IVM411,"^",10)'=IVM13
|
---|
16 | .S IVMOLD=$P(IVM411,"^",5)
|
---|
17 | .S IVMOLD=$S(IVMOLD="":"@",1:IVMOLD)
|
---|
18 | .S IVMFILE=$P(IVMAR1($P(IVM411,"^",2)),";")
|
---|
19 | .S IVMNOD=$P(IVMAR1($P(IVM411,"^",2)),";",2)
|
---|
20 | .I IVMFILE=408.13 S DA=IVM13,DIE="^DGPR(408.13,"
|
---|
21 | .I IVMFILE=408.12 S DA=IVM12,DIE="^DGPR(408.12,"
|
---|
22 | .S DR=IVMNOD_"////^S X=IVMOLD" D ^DIE K DA,DR,DIE
|
---|
23 | .Q
|
---|
24 | Q
|
---|
25 | ;
|
---|
26 | EN1 ; change primary income test for year? code from 0 to 1 for VAMC MT
|
---|
27 | S DA=IVMVAMC,DIE="^DGMT(408.31,",DR="2////1" D ^DIE K DA,DIE,DR
|
---|
28 | ;
|
---|
29 | ; delete 408.31
|
---|
30 | ;
|
---|
31 | S DA=IVMMTIEN,DIK="^DGMT(408.31," D ^DIK
|
---|
32 | ;
|
---|
33 | ; open IVM case record which was closed during upload
|
---|
34 | S DA=$O(^IVM(301.5,"APT",+DFN,+DGLY,0))
|
---|
35 | I $G(^IVM(301.5,+DA,0))']"" G MTBULL
|
---|
36 | S DR=".04////0",DIE="^IVM(301.5," D ^DIE
|
---|
37 | K ^IVM(301.5,DA,1)
|
---|
38 | ;
|
---|
39 | MTBULL ; build and transmit mail message to IVM mail group notifying site
|
---|
40 | ; that a means test was deleted.
|
---|
41 | S IVMPAT=$$PT^IVMUFNC4(DFN)
|
---|
42 | S XMSUB="IVM - MEANS TEST DELETED"
|
---|
43 | S IVMTEXT(1)="An Income Verification Match Means Test was deleted for the"
|
---|
44 | S IVMTEXT(2)="following patient:"
|
---|
45 | S IVMTEXT(3)=" "
|
---|
46 | S IVMTEXT(4)=" NAME: "_$P(IVMPAT,"^")
|
---|
47 | S IVMTEXT(5)=" ID: "_$P(IVMPAT,"^",2)
|
---|
48 | S Y=IVMMTDT X ^DD("DD")
|
---|
49 | S IVMTEXT(6)=" DATE OF TEST: "_Y
|
---|
50 | S IVMTEXT(7)=" "
|
---|
51 | S IVMTEXT(8)="NOTE: The original DHCP Means Test is now the primary Means Test."
|
---|
52 | D MAIL^IVMUFNC()
|
---|
53 | ;
|
---|
54 | ; call event driver
|
---|
55 | S DGMTINF=1,DGMTP=IVMNO,DGMTA=IVMVNO
|
---|
56 | S DGMTACT="DUP",DGMTI=IVMVAMC D EN^DGMTEVT
|
---|
57 | S DGMTACT="DEL",DGMTI=IVMMTIEN D EN^DGMTEVT
|
---|
58 | ;
|
---|
59 | ; cleanup
|
---|
60 | K DA,DFN,DGINC,DGINR,DGLY,DGMTA,DGMTACT,DGMTI,DGMTINF,DGMTP
|
---|
61 | K DIE,DIK,DR,IVM12,IVM121,IVM13,IVM41,IVM411,IVMFILE
|
---|
62 | K IVMFLGC,IVMMTDT,IVMMTIEN,IVMN,IVMNO,IVMNOD,IVMOLD
|
---|
63 | K IVMPAT,IVMSOT,IVMTEXT,IVMVAMC,IVMVAMCA,IVMVNO,XMSUB,Y
|
---|
64 | Q
|
---|
65 | ;
|
---|
66 | SETUPAR ; create array ivmar1
|
---|
67 | ; subscript is 408.42 node (type of change - name, dob, ssn, sex, relationship)
|
---|
68 | ; 1st piece is file 408.12 or 408.13
|
---|
69 | ; 2nd piece is 408.12 or 408.13 field #
|
---|
70 | F IVM41=4:1 S IVM411=$P($T(TYPECH+IVM41),";;",2) Q:IVM411="QUIT" D
|
---|
71 | .S IVMAR1($P(IVM411,";"))=$P(IVM411,";",2,3)
|
---|
72 | K IVM41,IVM411
|
---|
73 | Q
|
---|
74 | ;
|
---|
75 | TYPECH ; type of dependent changes 408.41/408.42
|
---|
76 | ; 1st piece - 408.42 table file node
|
---|
77 | ; 2nd piece - file (408.12/408.13)
|
---|
78 | ; 3rd piece - 408.12/408.13 field
|
---|
79 | ;;16;408.13;.01
|
---|
80 | ;;17;408.13;.03
|
---|
81 | ;;18;408.13;.09
|
---|
82 | ;;19;408.13;.02
|
---|
83 | ;;20;408.12;.02
|
---|
84 | ;;QUIT
|
---|