source: WorldVistAEHR/trunk/r/ENROLLMENT_APPLICATION_SYSTEM-EAS/EASUM8.m@ 1211

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

initial load of WorldVistAEHR

File size: 3.8 KB
Line 
1EASUM8 ;ALB/GN - DELETE IVM MEANS TEST (CON'T) ; 6/16/04 1:09am
2 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**42**;21-OCT-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;EAS*1*42 this routine patterned after IVMUM8
6 ; - add RX Copay Testing indentification to this routine.
7 ; - added language to the bulletin message specific to the
8 ; type of test being deleted. type = 1 (Means Test)
9 ; = 2 (RX Copay Test)
10 ;
11EN ; change demo data in 408.12 & 408.13 back to VAMC values
12 ; ivm12 408.12 ien
13 ; ivm13 408.13 ien
14 ; ivmmtien 408.31 ien
15 ;
16 ; note: 408.13 fields were added to 408.41 before 408.12 field
17 ;
18 K DR S IVM41=0
19 F S IVM41=$O(^DGMT(408.41,"D",IVMMTIEN,IVM41)) Q:'IVM41 D
20 .S IVM411=$G(^DGMT(408.41,+IVM41,0))
21 .Q:$P(IVM411,"^",10)'=IVM13
22 .S IVMOLD=$P(IVM411,"^",5)
23 .S IVMOLD=$S(IVMOLD="":"@",1:IVMOLD)
24 .S IVMFILE=$P(IVMAR1($P(IVM411,"^",2)),";")
25 .S IVMNOD=$P(IVMAR1($P(IVM411,"^",2)),";",2)
26 .I IVMFILE=408.13 S DA=IVM13,DIE="^DGPR(408.13,"
27 .I IVMFILE=408.12 S DA=IVM12,DIE="^DGPR(408.12,"
28 .S DR=IVMNOD_"////^S X=IVMOLD" D ^DIE K DA,DR,DIE
29 .Q
30 Q
31 ;
32EN1 ; change primary income test for year? code from 0 to 1 for VAMC MT
33 I IVMVAMC D
34 . S DA=IVMVAMC,DIE="^DGMT(408.31,",DR="2////1" D ^DIE K DA,DIE,DR
35 ;
36 ; Check link field, remove link before deleting record
37 N LNKTEST S LNKTEST=$P($G(^DGMT(408.31,IVMMTIEN,2)),U,6)
38 I LNKTEST S DA=LNKTEST,DIE="^DGMT(408.31,",DR="2.06////@" D ^DIE K DA,DIE,DR,LNKTEST
39 ;
40 ; delete 408.31
41 S DA=IVMMTIEN,DIK="^DGMT(408.31," D ^DIK
42 ;
43 ; open IVM case record which was closed during upload
44 S DA=$O(^IVM(301.5,"APT",+DFN,+DGLY,0))
45 I $G(^IVM(301.5,+DA,0))']"" G MTBULL
46 S DR=".04////0",DIE="^IVM(301.5," D ^DIE
47 K ^IVM(301.5,DA,1)
48 ;
49MTBULL ; Build and transmit mail message to IVM mail group notifying site
50 ; that an income test was deleted. Run MT event driver or only IB
51 ; event driver
52 ;
53 ;if deleting a previous IVM RXCT that had no previous VAMC 408.31,
54 ;then only call IB event driver for the IB delete
55 I '$D(IVMVNO) D
56 . S DGMTACT="DEL"
57 . D ^IBAMTED
58 E D
59 . ; call event driver
60 . S DGMTINF=1,DGMTP=IVMNO,DGMTA=IVMVNO
61 . S DGMTACT="DUP",DGMTI=IVMVAMC D EN^DGMTEVT
62 . S DGMTACT="DEL",DGMTI=IVMMTIEN D EN^DGMTEVT
63 ;
64 S IVMPAT=$$PT^IVMUFNC4(DFN)
65 S XMSUB="IVM - INCOME TEST DELETED"
66 S IVMTEXT(1)="An Income Verification Match "
67 S IVMTEXT(1)=IVMTEXT(1)_^DG(408.33,DGMTYPT,0)_" was deleted"
68 S IVMTEXT(2)="for the following patient:"
69 S IVMTEXT(3)=" "
70 S IVMTEXT(4)=" NAME: "_$P(IVMPAT,"^")
71 S IVMTEXT(5)=" ID: "_$P(IVMPAT,"^",2)
72 S Y=IVMMTDT X ^DD("DD")
73 S IVMTEXT(6)=" DATE OF TEST: "_Y
74 S IVMTEXT(7)=" "
75 S IVMTEXT(8)="NOTE: The original DHCP "
76 S IVMTEXT(8)=IVMTEXT(8)_^DG(408.33,DGMTYPT,0)_" is now primary"
77 S IVMTEXT(9)=" "
78 S IVMTEXT(10)=" PREV CATEGORY: "_DGCAT
79 ;
80 S IVMTEXT(11)=" NEW CATEGORY: "
81 I DGMTYPT=2 D
82 . S IVMTEXT(11)=IVMTEXT(11)_$P($$RXST^IBARXEU(DFN),"^",2)
83 E D
84 . Q:'IVMVAMC
85 . S IVMTEXT(11)=IVMTEXT(11)_$P($G(^DG(408.32,+$P(IVMVNO,"^",3),0)),"^",1)
86 D MAIL^IVMUFNC()
87 ;
88 ; cleanup
89 K DA,DFN,DGINC,DGINR,DGLY,DGMTA,DGMTACT,DGMTI,DGMTINF,DGMTP
90 K DIE,DIK,DR,IVM12,IVM121,IVM13,IVM41,IVM411,IVMFILE
91 K IVMFLGC,IVMMTDT,IVMMTIEN,IVMN,IVMNO,IVMNOD,IVMOLD
92 K IVMPAT,IVMSOT,IVMTEXT,IVMVAMC,IVMVAMCA,IVMVNO,XMSUB,Y
93 Q
94 ;
95SETUPAR ; create array ivmar1
96 ; subscript is 408.42 node (type of change - name, dob, ssn, sex, relationship)
97 ; 1st piece is file 408.12 or 408.13
98 ; 2nd piece is 408.12 or 408.13 field #
99 F IVM41=4:1 S IVM411=$P($T(TYPECH+IVM41),";;",2) Q:IVM411="QUIT" D
100 .S IVMAR1($P(IVM411,";"))=$P(IVM411,";",2,3)
101 K IVM41,IVM411
102 Q
103 ;
104TYPECH ; type of dependent changes 408.41/408.42
105 ; 1st piece - 408.42 table file node
106 ; 2nd piece - file (408.12/408.13)
107 ; 3rd piece - 408.12/408.13 field
108 ;;16;408.13;.01
109 ;;17;408.13;.03
110 ;;18;408.13;.09
111 ;;19;408.13;.02
112 ;;20;408.12;.02
113 ;;QUIT
Note: See TracBrowser for help on using the repository browser.