source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTR1.m@ 1259

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

initial load of WorldVistAEHR

File size: 5.0 KB
Line 
1DGMTR1 ;ALB/CJM,SCG,LBD - Check Means Test Requirements Cont'd;3/25/92 09:51
2 ;;5.3;Registration;**182,344,433,456,564**;Aug 13, 1993
3 ;
4COPYRX(DFN,MTIEN) ;
5 ;Creates a Pharmacy Copay test based on the means test if the vet is
6 ;subject to the Rx copayment and the income screening was already
7 ;completed
8 ;1/16/2002 - Changes added for LTC Copay Phase II (DG*5.3*433)
9 ;Creates a Pharmacy Copay test based on a LTC copay exemption test
10 ;(type 4) if the veteran is exempt from means test
11 ;
12 N NODE0,RXSTATUS,Y,DGMT,DGMTYPT,DGNODE,DATA,SUB,COMMENTS,RXIEN,DGMTACT,DGMTI,DGMTP,DGMTA,NODE2,CODE,QUIT,TRIES,ERROR,TYPE
13 ;
14 S DGMTP="",DGMTACT="ADD"
15 D ON^DGMTCOU G:'Y COPYRXQ
16 I $$CHK(DFN) D
17 .S NODE0=$G(^DGMT(408.31,MTIEN,0))
18 .Q:NODE0=""
19 .S NODE2=$G(^DGMT(408.31,MTIEN,2))
20 .;
21 .;get type of test (1=means test; 4=LTC copay exemption test)
22 .S TYPE=$P(NODE0,"^",19)
23 .;
24 .;must have been completed
25 .S CODE=$$GETCODE^DGMTH($P(NODE0,"^",3))
26 .S QUIT=1
27 .I (CODE'=""),("ACGP01"[CODE) S QUIT=0
28 .S CODE=$$GETCODE^DGMTH($P(NODE2,"^",3))
29 .I (CODE'=""),("ACGP01"[CODE) S QUIT=0
30 .Q:QUIT
31 .;
32 .;must still be effective
33 .Q:($$FMDIFF^XLFDT(DT,$P(NODE0,"^"))>365)
34 .Q:$$OLD^DGMTU4($P(NODE0,"^"))
35 .Q:($P(NODE0,"^",14)) ;declined to provide income information
36 .Q:($P(NODE0,"^",26)) ;refused to sign the test
37 .F TRIES=1:1 D Q:(TRIES>3)
38 ..S DGNODE=$$LST^DGMTU(DFN,$S((DT>$P(NODE0,"^",2)):DT,1:$P(NODE0,"^",2)),2),RXIEN=+DGNODE
39 ..;
40 ..;mark existing test as non-primary
41 ..I RXIEN,($E($P(DGNODE,"^",2),1,3)=$E($P(NODE0,"^"),1,3)) D
42 ...S DATA(2)=0 I $$UPD^DGENDBS(408.31,RXIEN,.DATA)
43 ..E S TRIES=4
44 .;
45 .S RXIEN=$P(NODE2,"^",6)
46 .;if already copied, reuse the same record
47 .I RXIEN,$P($G(^DGMT(408.31,RXIEN,2)),"^",6)=MTIEN D
48 ..S DGMTI=RXIEN
49 .E D Q:'DGMTI
50 ..;This call works. Adding via the ADD^DGENDBS encountered an error
51 ..S DGMTDT=$P(NODE0,"^") S DGMTYPT=2 D ADD^DGMTA
52 .;
53 .S DATA(.019)=2
54 .S DATA(.03)=""
55 .F SUB=.01,.02,.04,.05,.06,.07,.14,.15,.18,.23,.24,.25 S DATA(SUB)=$P(NODE0,"^",(SUB/.01))
56 .S DATA(2)=1
57 .S DATA(2.02)=$P(NODE2,"^",2)
58 .S DATA(2.05)=$P(NODE2,"^",5)
59 .I TYPE=1 D
60 ..S DATA(2.06)=MTIEN
61 ..S COMMENTS("LINES",1,0)="This Rx Copay Test was automatically created based on a completed means test"
62 ..S COMMENTS("LINES",2,0)="which was changed to NO LONGER REQUIRED. All data including income"
63 ..S COMMENTS("LINES",3,0)="screening was copied from the test on "_$$FMTE^XLFDT($$NOW^XLFDT)_"."
64 .I TYPE=4 D
65 ..S COMMENTS("LINES",1,0)="This Rx Copay Test was automatically created based on a completed"
66 ..S COMMENTS("LINES",2,0)="LTC copay exemption test. All data including income screening"
67 ..S COMMENTS("LINES",3,0)="was copied from the test on "_$$FMTE^XLFDT($$NOW^XLFDT)_"."
68 .S DATA(50)="COMMENTS(""LINES"")"
69 .S (DATA(.03),DATA(2.03))=$$RXSTATUS(MTIEN)
70 .I $$UPD^DGENDBS(408.31,DGMTI,.DATA,.ERROR)
71 .K DATA
72 .S:TYPE=1 DATA(2.06)=DGMTI
73 .S:TYPE=4 DATA(2.08)=DGMTI
74 .I $$UPD^DGENDBS(408.31,MTIEN,.DATA,.ERROR)
75 .D TRANSFER^DGMTU4(DFN,MTIEN,DGMTI)
76 .D QUE^DGMTR
77COPYRXQ ;
78 K ERROR
79 Q
80 ;
81RXSTATUS(MTIEN) ;
82 ;Determins RX Copay Status based on the means test
83 ;
84 Q:('$G(MTIEN)) ""
85 N NODE0,NODE,PIECE,IBSTATUS,MTSTATUS
86 S NODE0=$G(^DGMT(408.31,MTIEN,0))
87 Q:(NODE0="") ""
88 F PIECE=1,2,4,5,14,15,18 S $P(NODE,"^",PIECE)=$P(NODE0,"^",PIECE)
89 S $P(NODE,"^",19)=2
90 S IBSTATUS=+$$INCDT^IBARXEU1(NODE)
91 S MTSTATUS=$S(IBSTATUS=1:"E",IBSTATUS=2:"M",1:"")
92 Q:(MTSTATUS="") ""
93 Q $O(^DG(408.32,"AC",2,MTSTATUS,0))
94 ;
95CHK(DFN) ;
96 ;can the veteran take a RX copay test?
97 N DGMTI,DGMTCOR,DGNODE,DGELIG,DGI,DGE
98 S DGMTCOR=1
99 ;
100 I $P($G(^DPT(DFN,"VET")),U,1)'="Y" S DGMTCOR=0 G CHKQ ;NON-VET
101 S DGI=$P($G(^DPT(DFN,.36)),U) I 'DGI S DGMTCOR=0 G CHKQ ;NO PRIM ELIG
102 S DGELIG=U_$P($G(^DIC(8,+DGI,0)),U,9)_U
103 S DGI=0 F S DGI=$O(^DPT(DFN,"E",DGI)) Q:'DGI S DGE=$P($G(^DPT(DFN,"E",DGI,0)),U),DGELIG=DGELIG_$P($G(^DIC(8,+DGE,0)),U,9)_U
104 I (DGELIG["^1^") S DGMTCOR=0 G CHKQ ;SC 50-100%
105 F DGI=.3,.362,.52 S DGNODE(DGI)=$G(^DPT(DFN,DGI))
106 I $P(DGNODE(.362),U,12)["Y"!(DGELIG["^2^") S DGMTCOR=0 G CHKQ ;A&A
107 I $P(DGNODE(.362),U,13)["Y"!(DGELIG["^15^") S DGMTCOR=0 G CHKQ ;HB
108 I $P(DGNODE(.362),U,14)["Y"!(DGELIG["^4^") S DGMTCOR=0 G CHKQ ;PENSION
109 I $P(DGNODE(.52),U,5)["Y"!(DGELIG["^18^") S DGMTCOR=0 G CHKQ ;POW
110 I $P(DGNODE(.3),U,5)["Y"&($P(DGNODE(.3),U,2)>0)&($P(DGNODE(.362),U,20)>0) S DGMTCOR=0 G CHKQ ;UNEMPLOYABLE
111CHKQ ;
112 Q DGMTCOR
113MAIL ; Send a mailman msg to user/ INCONSISTENCY EDIT GROUP with results
114 N %,DGB,I,VA,VADM,VAERR,Y,XMDUZ,XMSUB,XMTEXT,XMY,XMZ
115 D DEM^VADPT
116 S XMSUB="Patient "_VADM(1)_" has an invalid secondary eligibility"
117 S XMDUZ="PIMS PACKAGE",XMY(DUZ)="",XMY(.5)=""
118 S DGB=+$P($G(^DG(43,1,"NOT")),"^",6)
119 I $D(^XMB(3.8,DGB,0)) S XMY("G."_$P($G(^XMB(3.8,DGB,0)),"^"))=""
120 S XMTEXT="DGTXT("
121 D NOW^%DTC S Y=% D DD^%DT
122 S DGTXT(1)="On "_Y_" "_VADM(1)_" ("_VA("BID")_")"
123 S DGTXT(2)="has an invalid secondary eligibility"
124 S DGTXT(3)=" "
125 ;que mailman message
126 N DIFROM,I,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
127 F I="DGTXT(","XMDUZ","XMSUB","XMTEXT","XMY(" S ZTSAVE(I)=""
128 S ZTDESC="MAILMAN MSG FOR INVALID ELIGIBILITY CODE FILE ENTRIES"
129 S ZTDTH=$$NOW^XLFDT(),ZTIO="",ZTRTN="^XMD"
130 D ^%ZTLOAD
131 Q
Note: See TracBrowser for help on using the repository browser.