source: FOIAVistA/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFRPC0.m@ 1499

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

initial load of FOIAVistA 6/30/08 version
File size: 7.6 KB
Line 
1RMPFRPC0 ;DDC/PJU - Module to establish DDC elig for ROES3 ;7/14/04
2 ;;3.0;REMOTE ORDER/ENTRY SYSTEM;**1**;11/1/02
3START(AR,DFN,SHW) ;called from RPC RMPFELIG
4 ;;input: array name by ref, DFN, SHW=1(opt) if prompts can be shown
5 ;;will return to the Delphi app as 0-7 subscripts in same order
6 ;created during calculation in the AR array (passed by reference)
7 ;PD = AR(0)=date of death msg or ""
8 ;ED = AR(1)=eligibility status date FM
9 ;EL = AR(2)=calculated eligibility code
10 ;ES = AR(3)=eligibility status
11 ;SR = AR(4)=sensitive record
12 ;ER = AR(5) is for error msg's
13 ;PE = AR(6)=primary eligibility
14 ;PG = AR(7)=priority group
15 ;RA = AR(8)=elig^APPR(1)/DISAPPR(0)/submit(2)^PSAS user^ASPS user^req dt^sug el^act dt
16 ;PS = enrollment group sub
17 ;R3 = array of auto accepted R3 elig's
18 K AR ;in case came in with data (is called by ref)
19 N ROES ;array of eligibilities to submitted to PSAS
20N N ED,EL,ES,FL,ER,PD,PE,PG,PS,R3,RA,SR,SSN,VS,VT,IEN
21 S (ED,EL,ES,FL,ER,PD,PE,PG,PS,R3,RA,SR,SSN,VS,VT,IEN)=""
22 F X=0:1:8 S AR(X)="" ;re-establish AR
23 F X="SC","COM","EP3","POW","AAA","HB","CAN","BRI","WWI" S R3(X)="" ;no PSAS ap needed
24D K VADM,VAEL,VAMB,VAPA,VASV
25 D DEM^VADPT ;sets up VADM() - demographic variables *** ck for errors
26 I $G(VAERR) S ER="**ERROR** Problem in retrieving Demographic values" G END
27 I $G(VADM(6)) D
28 .S (PD,AR(0))=VADM(6) ;fm^external date of death
29 S SSN=$P($G(VADM(2)),U,1)
30 ;*** ADDED TO Integration agreement 767 NAME: DBIA268-C SEN REC ***
31 I $P($G(^DGSL(38.1,DFN,0)),U,2) S AR(4)=1 ;ck for sensitive record
32 S VAPA("P")="" D ADD^VADPT ;get permanent address
33 I $G(VAERR) S ER="**ERROR** Problem in retrieving Permanent Address" G END
34E D ELIG^VADPT ;sets up VAEL() - eligibility variables & ck for errors
35 I $G(VAERR) D G END
36 .S ER="**ERROR** Problem in retrieving Eligibility from ELIG^VADPT"
37 I $L(ER) G END
38 S (PE,AR(6))=$P($G(VAEL(1)),U,2) ;external form of PRIMARY ELIG
39 S ES=$P($G(VAEL(8)),U,1) ;elig status
40 I ES="V" D
41 .K RM S DIC=2,DA=DFN,DIQ="RM",DR=".3612" D EN^DIQ1
42 .S ED=RM(2,DFN,.3612) ;elig date text
43 .S %DT="X",X=ED D ^%DT S:+Y>1 ED=+Y_U_ED ;fmdate ^ text date
44 .K RM,DIC,DA,DIQ,DR
45 S VT=$S($G(VAEL(4)):"Y",1:"N") ;VET Y/N
46 I VT="Y" D ;G:$L(EL) END ;11/19/03 need PG for ALL
47 .D ELIGBL Q:$L(EL) ; checks for SC for condition SC
48 .S VS=$G(VAEL(3)) I $P(VS,U,1) D ;VAEL(3)=0/1 for SC ^ %
49 ..I $P(VS,U,2)'<10 S EL="COM" ;SC 10% or greater COM
50 K RM S DIC=2,DA=DFN,DIQ="RM",DR="27.01",DIQ(0)="I" D EN^DIQ1
51 S DA=$G(RM(2,DFN,27.01,"I")) ;CURRENT ENROLLMENT entry in patient file
52 I DA D
53 .K RM2 S DIC=27.11,DIQ="RM2",DR=".07;.12",DIQ(0)="I" D EN^DIQ1
54 .S (PG,AR(7))=$G(RM2(27.11,DA,.07,"I")) ;Priority Group
55 .S PS1=$G(RM2(27.11,DA,.12,"I"))
56 .S PS=$S(PS1=1:"A",PS1=2:"B",PS1=3:"C",PS1=4:"D",1:"") ;Priority Subgroup
57 K RM,RM2,DIC,DA,DIQ,DR,PS1
58 G:$L(EL) END ;11/19/03 now can go to end if know EL
59 I VT="Y",PG=3 D G:$L(EL) END
60 .S EL="EP3" ; EP3
61 D SVC^VADPT I $G(VAERR) D G END
62 .S ER="**ERROR** Problem in retrieving Service Information(SVC^VADPT)"
63 I ($G(VASV(4))=1)!($P(VAEL(1),U,2)="PRISONER OF WAR") D G:$L(EL) END
64 .S EL="POW" ; POW
65 D MB^VADPT I $G(VAERR) D G END
66 .S ER="**ERROR** Problem in retrieving Benefit information(MB^VADPT)"
67 ; VAEL(1)=#^PRIMARY ELIG
68 I VT="Y" D G:$L(EL) END
69 .I $G(VAMB(1))!($P(VAEL(1),U,2)="AID & ATTENDANCE") S EL="AAA" Q ; AAA **PRI ELIG
70 .I $G(VAMB(2))!($P(VAEL(1),U,2)="HOUSEBOUND") S EL="HB" Q ; HB **
71 .I $G(VAEL(3)),$P($G(VAEL(3)),U,2)=0 D Q:$L(EL) ; 0CA
72 ..I PG=5 S EL="0CA" Q
73 ..I PG=7,PS="A" S EL="0CA"
74 .I PG=5 D Q:$L(EL) ; NCA**
75 ..I $P($G(VAEL(1)),U,2)="NSC, VA PENSION" S EL="NCA" Q ;PG5 NSC, VA PENSION primary eligibility
76 ..I $P($G(VAEL(6)),U,2)="NSC VETERAN" S EL="NCA" Q ;PG 5 NSC Veteran
77 .;I PG=6 S EL="SCV" Q ;Special category veterans SCV
78 .I ($P($G(VAEL(2)),U,2)="WORLD WAR I")!($P($G(VAEL(2)),U,2)="MEXICAN BORDER WAR") D
79 ..S EL="WWI" ; WWI
80 G:$L(EL) END
81 D ALLIED(DFN) G:$L(EL) END ; CAN or BRI
82 S X=0 D:($D(VAEL(1))>9) G:$L(EL) END ; OGA
83 .F S X=$O(VAEL(1,X)) Q:'X D Q:$L(EL)
84 ..I $P(VAEL(1,X),U,2)="OTHER FEDERAL AGENCY" S EL="OGA"
85 I VT="Y",'$G(VAEL(3)) D G:$L(EL) END ; NSC
86 .I (PG=7)&(PS="C") S EL="NSC"
87 I VT="Y",PG=8 S EL="PG8" ; PG8
88END I $L($G(ER)) S AR(5)=ER
89 S:$L(ED) AR(1)=ED ; ELIG DATE
90 S:$L(EL) AR(2)=EL ; calc elig CODE
91 S:$L($G(ES)) AR(3)=ES ; ELIG STAT
92 ;CK FOR ACCEPTANCE OR REJECTION
93 S IEN="" I $D(^RMPF(791814,"B",DFN)) D
94 .S IEN=$O(^RMPF(791814,"B",DFN," "),-1)
95 G:'IEN END2
96 I (EL="")!(EL="NSC")!(EL="BLR")!(EL="VOC")!(EL="OGA")!(EL="PG8")!(EL="NCA")!(EL="0CA") D
97 .S RA=$P($G(^RMPF(791814,IEN,2)),U,2) ;0 or 1 or 2
98 .S:RA="" RA=2 ;submitted, but not acted on
99 .S EL=$S(RA=1:$P($G(^RMPF(791814,IEN,2)),U,1),1:EL),AR(2)=EL ;appr elig code or CALC
100 .S X=$P($G(^RMPF(791814,IEN,2)),U,3),Y="Unknown" ;PSAS user DUZ
101 .I X>0 S DIC=200,DIC(0)="N" D ^DIC D
102 ..S Y=$S(+Y>0:$P(Y,U,2),1:"Unknown") K DIC
103 ..S $P(RA,U,2)=Y ;name of PSAS user
104 .S X=$P($G(^RMPF(791814,IEN,0)),U,3),Y="Unknown" ;ASPS user DUZ
105 .I X>0 S DIC=200,DIC(0)="N" D ^DIC D
106 ..S Y=$S(+Y>0:$P(Y,U,2),1:"Unknown") K DIC
107 ..S $P(RA,U,3)=Y ;name of ASPS user
108 .S:$L(RA) AR(8)=EL_U_RA ;elg^0/1/2^PSAS user^ASPS user name
109 .S Y=$P(^RMPF(791814,IEN,0),U,2) D DD^%DT ;ret Y=date of req
110 .S $P(AR(8),U,5)=Y ;elg^0/1/2^PSAS user ^ASPS user name^dt req ent
111 .I $D(^RMPF(791814,IEN,1)) D
112 ..S $P(AR(8),U,6)=$P(^RMPF(791814,IEN,1),U,1) ;sugg elig
113 .I $D(^RMPF(791814,IEN,2)) D
114 ..S Y=$P(^RMPF(791814,IEN,2),U,4) D:$L(Y) DD^%DT
115 ..S $P(AR(8),U,7)=Y ;Action date
116END2 D:$G(SHW) SHOW ; show calc'd values for testing
117 D KVAR^VADPT K LD,S0,S1,S2,S6,YY,POP
118 Q
119ELIGBL ;ELIGIBILITY FOR DISABILITY CONDITION
120 ;contains DFN,.372,X,0)=31 ptr^disabil %^SC 0/1
121 ;DIC(31,i,0)= disab txt^abbrev^dx code
122 N LD,S,RD,P,AX S AX=0
123E1 ;*** added to IA #174 for rated disabilities multiple node direct read
124 S AX=$O(^DPT(DFN,.372,AX)) G E1END:'AX
125 I $D(^DPT(DFN,.372,AX,0)) D G:$L(EL) E1END
126 .S S=^DPT(DFN,.372,AX,0) I $P(S,U,3) D ;service connected
127 ..S RD=$P(S,U,1) D:RD ;disibility file ptr
128 ...S X=RD,DIC=31,DIC(0)="NZ" D ^DIC
129 ...S LD=$S(+Y>0:$P(Y(0),U,3),1:"Unknown") K DIC,Y
130 ...Q:+LD<5000 Q:+LD>6300 S LD=+LD ;ck hearing loss DX codes/ck on codes 6259 & 6298
131 ...I (LD=6016)!((LD>6099)&(LD<6111)) S EL="SC" Q
132 ...I ((LD>6198)&(LD<6212))!((LD>6249)&(LD<6264)) S EL="SC" Q ; SC for condition
133 ...I ((LD>6276)&(LD<6300)) S EL="SC"
134 G E1 ;dis
135E1END Q
136 ;
137SHOW ;all visible prompts if needed FOR TESTING ONLY
138 ;ZW AR ; for testing
139 W !!,"Patient: " I $G(DFN) W $S($D(^DPT(DFN,0)):$P(^(0),U,1),1:DFN)
140 I $L(EL) D
141 .W !,"Calculated R3 elig = ",EL
142 .I '$D(R3(EL)) D
143 ..W !," ***** ","ROES3 ELIGIBILITY MUST BE APPROVED BY PSAS *****"
144 I '$L(EL) D
145 .W !," ***** ","ROES3 ELIGIBILITY NOT DETERMINED, ORDER MUST BE APPROVED BY PSAS *****"
146 W !,"VA Elig status: "
147 I $L(ES) W ES
148 E W !," ***** ","NO ELIG STATUS - MUST BE APPROVED BY PSAS *****"
149 W !,"Elig status date: " I $L(ED) W ED
150ENDS Q
151 ;
152ALLIED(DFN) ;;input: DFN
153 ;;output: EL= CAN or BRI if true
154 I $P(VAEL(3),U,1)=1 D ;sc
155 .N DIC,DA,DIQ,DR,RM
156 .S DIC=2,DA=DFN,DIQ="RM",DR=".309" D EN^DIQ1
157 .S:(RM(2,DFN,.309)="CANADA") EL="CAN"
158 .S:(RM(2,DFN,.309)["BRITAIN") EL="BRI"
159 Q
Note: See TracBrowser for help on using the repository browser.