RMPFRPC0 ;DALC/PJU - Module to establish DALC elig for ROES3;06/18/2008
;;3.0;REMOTE ORDER ENTRY SYSTEM;**1,4**;Feb 9, 2011;Build 19
;;Updated for R3*4 2/1/2011
;;Per VHA Directive 10-92-142 this routine should not be modified
;;Uses supported IA's: 2343, 10003, 10015, 10061, 10103
;;subscriber to IA's: 174 & 767
START(AR,DFN,SHW) ;called from RMPFRPC1 for elig variables
;input: array name by ref, DFN, SHW=1(opt) if prompts can be shown
;will return to the Delphi app as 0-7 subscripts in same order
;PD = AR(0)=date of death msg or ""
;ED = AR(1)=eligibility status date FM
;EL = AR(2)=calculated eligibility code
;ES = AR(3)=eligibility status
;SR = AR(4)=sensitive record
;ER = AR(5) is for error msg's
;PE = AR(6)=primary eligibility
;PG = AR(7)=priority group
;RA = AR(8)=elig^APPR(1)^PSAS user^ASPS user^req dt^sug el^act dt
;PS = enrollment group sub
;R3 = array of auto accepted R3 elig's
;VS = 0/1 for SC ^ %
;VT = y/n for veteran flag
K AR ;in case came in with data (is called by ref)
N ROES ;array of eligibilities to submitted to PSAS
N A0,A1,A2,ED,EL,ES,ER,PD,PG,PS,R3,RA,RMDNM,SSN,VS,VT,IEN
S (ED,EL,ES,ER,PD,PG,PS,R3,RA,RMDNM,SSN,VS,VT,IEN)=""
F X=0:1:8 S AR(X)="" ;initialize array AR
;R3*4 removed or renamed:"WWI","AAA","EP3","HB"
F X="SC","COM","PH","POW","PG3","PG4","NCA","0CA","OIF" S R3(X)=""
F X="SCV","OGA","NSC","PG8","BLR","VOC","CAN","BRI" S R3(X)=""
K VADM,VAEL,VAMB,VAPA,VASV
D DEM^VADPT ;demographic vars
I $G(VAERR) S ER="**ERROR retrieving Demographic values**" G END
I $G(VADM(6)) D ;fm^external date of death
.S (PD,AR(0))=VADM(6)
S RMDNM=$G(VADM(1)) ;Patient name for SHOW
S SSN=$P($G(VADM(2)),U,1)
I $P($G(^DGSL(38.1,DFN,0)),U,2) S AR(4)=1 ;IA 767 (DBIA268-C SEN REC)
S VAPA("P")="" D ADD^VADPT ;permanent address
I $G(VAERR) S ER="**ERROR** Problem retrieving Permanent Address" G END
D ELIG^VADPT ;eligibility vars
I $G(VAERR) D G END
.S ER="**ERROR** Problem in retrieving Eligibility (VADPT)."
I $L(ER) G END
S AR(6)=$P($G(VAEL(1)),U,2) ;external form PRIMARY ELIG
S ES=$P($G(VAEL(8)),U,1) ;elig status
I ES="V" D ;verified
.K RM S DIC=2,DA=DFN,DIQ="RM",DR=".3612" D EN^DIQ1
.S ED=RM(2,DFN,.3612) ;elig date text
.S %DT="X",X=ED D ^%DT S:+Y>1 ED=+Y_U_ED ;fmdate ^ text date
.K RM,DIC,DA,DIQ,DR,%DT
S VT=$S($G(VAEL(4)):"Y",1:"N") ;VET Y/N
K RM S DIC=2,DA=DFN,DIQ="RM",DR="27.01",DIQ(0)="I" D EN^DIQ1
S DA=$G(RM(2,DFN,27.01,"I")) ;CURRENT ENROLLMENT entry in ^DPT(
I DA D
.K RM2 S DIC=27.11,DIQ="RM2",DR=".07;.12",DIQ(0)="I" D EN^DIQ1
.S (PG,AR(7))=$G(RM2(27.11,DA,.07,"I")) ;Priority Group
.S PS1=$G(RM2(27.11,DA,.12,"I"))
.S PS=$S(PS1=1:"A",PS1=2:"B",PS1=3:"C",PS1=4:"D",1:"") ;PG Subgroup
K RM,RM2,DIC,DA,DIQ,DR,PS1
I VT="Y" D ;is veteran
.D ELIGBL Q:$L(EL) ; ck for SC for condition *** SC **
.S VS=$G(VAEL(3)) I $P(VS,U,1) D ;(3)=0/1 for SC ^ %
..I $P(VS,U,2)'<10 D
...I +PG>0,+PG<4 S EL="COM" ;PG 1-3 & SC >= 10% *** COM **
G:$L(EL) END ;EL = COM or SC
D SVC^VADPT I $G(VAERR) D G END ;Service Info(SVC^VADPT)
.S ER="**ERROR** Problem in retrieving Service Information."
I ($G(VASV(4))=1)!($P(VAEL(1),U,2)="PRISONER OF WAR") D G:$L(EL) END
.S EL="POW" ;VASV(4)= POW status (1/0) *** POW **
I +$G(VASV(9)) S EL="PH" G END ;VASV(9)=1(current PH),else 0 ** PH **
I VT="Y" D G:$L(EL) END
.S:PG=3 EL="PG3" ; *** PG3 **
.S:PG=4 EL="PG4" ; include AAA & HB & catastrophic disabled ** PG4 **
;VAMB(1)=recv A&A ben's;VAMB(2)=recv HB bens both in PG4
D ALLIED(DFN) G:$L(EL) END ; *** CAN or BRI **
I VT="Y" D G:$L(EL) END
.I PG=5 D Q:$L(EL) ; *** NCA **
..I $P($G(VAEL(1)),U,2)="NSC, VA PENSION" S EL="NCA" Q
..S:$P($G(VAEL(6)),U,2)="NSC VETERAN" EL="NCA"
.I $G(VAEL(3)),$P($G(VAEL(3)),U,2)=0 D Q:$L(EL) ; *** 0CA **
..I (PG=5)!(PG=7)!(PG=8) S EL="0CA" Q
.I PG=6 D Q:$L(EL) ;VASV(11)= # OIF/OEF tours
..I +$G(VASV(11))>0 S EL="OIF" ; *** OIF ***
..E S EL="SCV" ;Special category veterans *** SCV **
G:$L(EL) END
S X=0 I ($D(VAEL(1))>9) D G:$L(EL) END ; *** OGA **
.F S X=$O(VAEL(1,X)) Q:'X D Q:$L(EL)
..I $P(VAEL(1,X),U,2)="OTHER FEDERAL AGENCY" S EL="OGA"
I VT="Y",'$G(VAEL(3)) D G:$L(EL) END ; *** NSC **
.I (PG=7) S EL="NSC"
I VT="Y",PG=8 S EL="PG8" ; *** PG8 **
END I $L($G(ER)) S AR(5)=ER
S:$L(ED) AR(1)=ED ; *** ELIG DATE **
S:$L(EL) AR(2)=EL ; *** calc elig CODE
S:$L($G(ES)) AR(3)=ES ;ELIG STAT
G:$L(EL) END2 ;R3*4
;if 'EL ck for PRIOR elig in ELIGIBILITY CONFIRMATION file
S IEN="" I $D(^RMPF(791814,"B",DFN)) D
.S IEN=$O(^RMPF(791814,"B",DFN," "),-1)
G:'IEN END2
S A0=$G(^RMPF(791814,IEN,0)),A1=$G(^(1)),A2=$G(^(2))
S RA=$P(A2,U,2) ;0 or 1 or 2 (REJ, APPR, WAIT)
I +RA<1 S RA=1,EL="NSC",$P(A2,U,1)=EL ;DEFAULT DISAPPROVED CHG'D TO NSC APPROVED
I (RA>1) S RA=1 D ; others auto approve
.I $P(A2,U,1)'="" S EL=$P(A2,U,1) ;PSAS ELIG
.I EL="" S EL="NSC",$P(A1,U,1)=EL ;DEFAULT
.S AR(2)=EL ;calculated elig
.S X=$P(A2,U,3) S:(+X<1) X=DUZ ;psas or user DUZ
.S Y=$$NAME^XUSER(X) S:Y="" Y="Unknown"
.S $P(RA,U,2)=Y ;name
.S X=$P(A0,U,3) S:(+X<1) X=DUZ ;ASPS user DUZ
.S Y=$$NAME^XUSER(X) S:Y="" Y="Unknown"
.S $P(RA,U,3)=Y ;name
.S AR(8)=EL_U_RA ;elg^1^PSAS user^ASPS user
.S Y=$P(A2,U,4) ;action date
.I Y="" S Y=DT
.D DD^%DT S $P(AR(8),U,7)=Y ;Action date
;;AR(8)=elg^1^P-user^A-user^entry DT^elg^Act DT
END2 I EL="" S EL="NSC" D ;DEFAULT FOR R3*4 1/26/2011
.S Y=DT D DD^%DT S ED=Y
.S AR(1)=ED ; *** ELIG DATE **
.S AR(2)=EL ; *** calc elig CODE
D:$G(SHW) SHOW ;SHW=1 to show calc'd values for TESTING ONLY
D KVAR^VADPT K LD,S0,S1,S2,S6,YY,POP,VAERR
Q
;
ELIGBL ;ELIGIBILITY FOR DISABILITY CONDITION - SC
;contains DFN,.372,X,0)=31 ptr^disabil %^SC 0/1
;DIC(31,i,0)= disab txt^abbrev^dx code
Q:(+PG<1) I "123578"'[PG Q ;just 1,2,3,5,7&8 per Kyle 1/14/09
Q:'$D(^DPT(DFN,.372)) N LD,S,RD,P,AX S AX=0
E1 ;*** added IA #174(rated disabilities mult node direct read)
S AX=$O(^DPT(DFN,.372,AX)) G E1END:'AX
I $D(^DPT(DFN,.372,AX,0)) D G:$L(EL) E1END
.S S=^DPT(DFN,.372,AX,0) I $P(S,U,3) D ;service connected
..S RD=$P(S,U,1) D:RD ;disibility file ptr
...S X=RD,DIC=31,DIC(0)="NZ" D ^DIC
...S LD=$S(+Y>0:$P(Y(0),U,3),1:"Unknown") K DIC,Y ;DX codes
...Q:+LD<5000 Q:+LD>6300 S LD=+LD ;ck specific hearing DX codes
...I (LD=6016)!((LD>6099)&(LD<6111)) S EL="SC" Q
...I ((LD>6198)&(LD<6212))!((LD>6249)&(LD<6264)) S EL="SC" Q
...I ((LD>6276)&(LD<6300)) S EL="SC"
G E1 ;dis
E1END Q
;
ALLIED(DFN) ;Determine if qualifying Allied Veteran
;output: EL= CAN or BRI if true
N DIC,DA,DIQ,DR,RM
I $P(VAEL(3),U,1)=1 D ; SC
.S DIC=2,DA=DFN,DIQ="RM",DR=".309" D EN^DIQ1
.S:(RM(2,DFN,.309)="CANADA") EL="CAN"
.S:(RM(2,DFN,.309)["BRITAIN") EL="BRI"
Q
;
SHOW ;View data retrieved - for debugging only if SHW=1
;called from END2
W !!,"Patient: ",$G(RMDNM)
W !,"Calculated R3 elig = " W:$L(EL) EL
W !,"VA Elig status: " W:$L(ES) ES
W !,"Elig status date: " W:$L(ED) ED
;W ! ZW AR ;FOR TESTING ONLY
ENDS Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFRPC0 7300 printed Nov 22, 2024@17:46:58 Page 2
RMPFRPC0 ;DALC/PJU - Module to establish DALC elig for ROES3;06/18/2008
+1 ;;3.0;REMOTE ORDER ENTRY SYSTEM;**1,4**;Feb 9, 2011;Build 19
+2 ;;Updated for R3*4 2/1/2011
+3 ;;Per VHA Directive 10-92-142 this routine should not be modified
+4 ;;Uses supported IA's: 2343, 10003, 10015, 10061, 10103
+5 ;;subscriber to IA's: 174 & 767
START(AR,DFN,SHW) ;called from RMPFRPC1 for elig variables
+1 ;input: array name by ref, DFN, SHW=1(opt) if prompts can be shown
+2 ;will return to the Delphi app as 0-7 subscripts in same order
+3 ;PD = AR(0)=date of death msg or ""
+4 ;ED = AR(1)=eligibility status date FM
+5 ;EL = AR(2)=calculated eligibility code
+6 ;ES = AR(3)=eligibility status
+7 ;SR = AR(4)=sensitive record
+8 ;ER = AR(5) is for error msg's
+9 ;PE = AR(6)=primary eligibility
+10 ;PG = AR(7)=priority group
+11 ;RA = AR(8)=elig^APPR(1)^PSAS user^ASPS user^req dt^sug el^act dt
+12 ;PS = enrollment group sub
+13 ;R3 = array of auto accepted R3 elig's
+14 ;VS = 0/1 for SC ^ %
+15 ;VT = y/n for veteran flag
+16 ;in case came in with data (is called by ref)
KILL AR
+17 ;array of eligibilities to submitted to PSAS
NEW ROES
+18 NEW A0,A1,A2,ED,EL,ES,ER,PD,PG,PS,R3,RA,RMDNM,SSN,VS,VT,IEN
+19 SET (ED,EL,ES,ER,PD,PG,PS,R3,RA,RMDNM,SSN,VS,VT,IEN)=""
+20 ;initialize array AR
FOR X=0:1:8
SET AR(X)=""
+21 ;R3*4 removed or renamed:"WWI","AAA","EP3","HB"
+22 FOR X="SC","COM","PH","POW","PG3","PG4","NCA","0CA","OIF"
SET R3(X)=""
+23 FOR X="SCV","OGA","NSC","PG8","BLR","VOC","CAN","BRI"
SET R3(X)=""
+24 KILL VADM,VAEL,VAMB,VAPA,VASV
+25 ;demographic vars
DO DEM^VADPT
+26 IF $GET(VAERR)
SET ER="**ERROR retrieving Demographic values**"
GOTO END
+27 ;fm^external date of death
IF $GET(VADM(6))
Begin DoDot:1
+28 SET (PD,AR(0))=VADM(6)
End DoDot:1
+29 ;Patient name for SHOW
SET RMDNM=$GET(VADM(1))
+30 SET SSN=$PIECE($GET(VADM(2)),U,1)
+31 ;IA 767 (DBIA268-C SEN REC)
IF $PIECE($GET(^DGSL(38.1,DFN,0)),U,2)
SET AR(4)=1
+32 ;permanent address
SET VAPA("P")=""
DO ADD^VADPT
+33 IF $GET(VAERR)
SET ER="**ERROR** Problem retrieving Permanent Address"
GOTO END
+34 ;eligibility vars
DO ELIG^VADPT
+35 IF $GET(VAERR)
Begin DoDot:1
+36 SET ER="**ERROR** Problem in retrieving Eligibility (VADPT)."
End DoDot:1
GOTO END
+37 IF $LENGTH(ER)
GOTO END
+38 ;external form PRIMARY ELIG
SET AR(6)=$PIECE($GET(VAEL(1)),U,2)
+39 ;elig status
SET ES=$PIECE($GET(VAEL(8)),U,1)
+40 ;verified
IF ES="V"
Begin DoDot:1
+41 KILL RM
SET DIC=2
SET DA=DFN
SET DIQ="RM"
SET DR=".3612"
DO EN^DIQ1
+42 ;elig date text
SET ED=RM(2,DFN,.3612)
+43 ;fmdate ^ text date
SET %DT="X"
SET X=ED
DO ^%DT
if +Y>1
SET ED=+Y_U_ED
+44 KILL RM,DIC,DA,DIQ,DR,%DT
End DoDot:1
+45 ;VET Y/N
SET VT=$SELECT($GET(VAEL(4)):"Y",1:"N")
+46 KILL RM
SET DIC=2
SET DA=DFN
SET DIQ="RM"
SET DR="27.01"
SET DIQ(0)="I"
DO EN^DIQ1
+47 ;CURRENT ENROLLMENT entry in ^DPT(
SET DA=$GET(RM(2,DFN,27.01,"I"))
+48 IF DA
Begin DoDot:1
+49 KILL RM2
SET DIC=27.11
SET DIQ="RM2"
SET DR=".07;.12"
SET DIQ(0)="I"
DO EN^DIQ1
+50 ;Priority Group
SET (PG,AR(7))=$GET(RM2(27.11,DA,.07,"I"))
+51 SET PS1=$GET(RM2(27.11,DA,.12,"I"))
+52 ;PG Subgroup
SET PS=$SELECT(PS1=1:"A",PS1=2:"B",PS1=3:"C",PS1=4:"D",1:"")
End DoDot:1
+53 KILL RM,RM2,DIC,DA,DIQ,DR,PS1
+54 ;is veteran
IF VT="Y"
Begin DoDot:1
+55 ; ck for SC for condition *** SC **
DO ELIGBL
if $LENGTH(EL)
QUIT
+56 ;(3)=0/1 for SC ^ %
SET VS=$GET(VAEL(3))
IF $PIECE(VS,U,1)
Begin DoDot:2
+57 IF $PIECE(VS,U,2)'<10
Begin DoDot:3
+58 ;PG 1-3 & SC >= 10% *** COM **
IF +PG>0
IF +PG<4
SET EL="COM"
End DoDot:3
End DoDot:2
End DoDot:1
+59 ;EL = COM or SC
if $LENGTH(EL)
GOTO END
+60 ;Service Info(SVC^VADPT)
DO SVC^VADPT
IF $GET(VAERR)
Begin DoDot:1
+61 SET ER="**ERROR** Problem in retrieving Service Information."
End DoDot:1
GOTO END
+62 IF ($GET(VASV(4))=1)!($PIECE(VAEL(1),U,2)="PRISONER OF WAR")
Begin DoDot:1
+63 ;VASV(4)= POW status (1/0) *** POW **
SET EL="POW"
End DoDot:1
if $LENGTH(EL)
GOTO END
+64 ;VASV(9)=1(current PH),else 0 ** PH **
IF +$GET(VASV(9))
SET EL="PH"
GOTO END
+65 IF VT="Y"
Begin DoDot:1
+66 ; *** PG3 **
if PG=3
SET EL="PG3"
+67 ; include AAA & HB & catastrophic disabled ** PG4 **
if PG=4
SET EL="PG4"
End DoDot:1
if $LENGTH(EL)
GOTO END
+68 ;VAMB(1)=recv A&A ben's;VAMB(2)=recv HB bens both in PG4
+69 ; *** CAN or BRI **
DO ALLIED(DFN)
if $LENGTH(EL)
GOTO END
+70 IF VT="Y"
Begin DoDot:1
+71 ; *** NCA **
IF PG=5
Begin DoDot:2
+72 IF $PIECE($GET(VAEL(1)),U,2)="NSC, VA PENSION"
SET EL="NCA"
QUIT
+73 if $PIECE($GET(VAEL(6)),U,2)="NSC VETERAN"
SET EL="NCA"
End DoDot:2
if $LENGTH(EL)
QUIT
+74 ; *** 0CA **
IF $GET(VAEL(3))
IF $PIECE($GET(VAEL(3)),U,2)=0
Begin DoDot:2
+75 IF (PG=5)!(PG=7)!(PG=8)
SET EL="0CA"
QUIT
End DoDot:2
if $LENGTH(EL)
QUIT
+76 ;VASV(11)= # OIF/OEF tours
IF PG=6
Begin DoDot:2
+77 ; *** OIF ***
IF +$GET(VASV(11))>0
SET EL="OIF"
+78 ;Special category veterans *** SCV **
IF '$TEST
SET EL="SCV"
End DoDot:2
if $LENGTH(EL)
QUIT
End DoDot:1
if $LENGTH(EL)
GOTO END
+79 if $LENGTH(EL)
GOTO END
+80 ; *** OGA **
SET X=0
IF ($DATA(VAEL(1))>9)
Begin DoDot:1
+81 FOR
SET X=$ORDER(VAEL(1,X))
if 'X
QUIT
Begin DoDot:2
+82 IF $PIECE(VAEL(1,X),U,2)="OTHER FEDERAL AGENCY"
SET EL="OGA"
End DoDot:2
if $LENGTH(EL)
QUIT
End DoDot:1
if $LENGTH(EL)
GOTO END
+83 ; *** NSC **
IF VT="Y"
IF '$GET(VAEL(3))
Begin DoDot:1
+84 IF (PG=7)
SET EL="NSC"
End DoDot:1
if $LENGTH(EL)
GOTO END
+85 ; *** PG8 **
IF VT="Y"
IF PG=8
SET EL="PG8"
END IF $LENGTH($GET(ER))
SET AR(5)=ER
+1 ; *** ELIG DATE **
if $LENGTH(ED)
SET AR(1)=ED
+2 ; *** calc elig CODE
if $LENGTH(EL)
SET AR(2)=EL
+3 ;ELIG STAT
if $LENGTH($GET(ES))
SET AR(3)=ES
+4 ;R3*4
if $LENGTH(EL)
GOTO END2
+5 ;if 'EL ck for PRIOR elig in ELIGIBILITY CONFIRMATION file
+6 SET IEN=""
IF $DATA(^RMPF(791814,"B",DFN))
Begin DoDot:1
+7 SET IEN=$ORDER(^RMPF(791814,"B",DFN," "),-1)
End DoDot:1
+8 if 'IEN
GOTO END2
+9 SET A0=$GET(^RMPF(791814,IEN,0))
SET A1=$GET(^(1))
SET A2=$GET(^(2))
+10 ;0 or 1 or 2 (REJ, APPR, WAIT)
SET RA=$PIECE(A2,U,2)
+11 ;DEFAULT DISAPPROVED CHG'D TO NSC APPROVED
IF +RA<1
SET RA=1
SET EL="NSC"
SET $PIECE(A2,U,1)=EL
+12 ; others auto approve
IF (RA>1)
SET RA=1
Begin DoDot:1
+13 ;PSAS ELIG
IF $PIECE(A2,U,1)'=""
SET EL=$PIECE(A2,U,1)
+14 ;DEFAULT
IF EL=""
SET EL="NSC"
SET $PIECE(A1,U,1)=EL
+15 ;calculated elig
SET AR(2)=EL
+16 ;psas or user DUZ
SET X=$PIECE(A2,U,3)
if (+X<1)
SET X=DUZ
+17 SET Y=$$NAME^XUSER(X)
if Y=""
SET Y="Unknown"
+18 ;name
SET $PIECE(RA,U,2)=Y
+19 ;ASPS user DUZ
SET X=$PIECE(A0,U,3)
if (+X<1)
SET X=DUZ
+20 SET Y=$$NAME^XUSER(X)
if Y=""
SET Y="Unknown"
+21 ;name
SET $PIECE(RA,U,3)=Y
+22 ;elg^1^PSAS user^ASPS user
SET AR(8)=EL_U_RA
+23 ;action date
SET Y=$PIECE(A2,U,4)
+24 IF Y=""
SET Y=DT
+25 ;Action date
DO DD^%DT
SET $PIECE(AR(8),U,7)=Y
End DoDot:1
+26 ;;AR(8)=elg^1^P-user^A-user^entry DT^elg^Act DT
END2 ;DEFAULT FOR R3*4 1/26/2011
IF EL=""
SET EL="NSC"
Begin DoDot:1
+1 SET Y=DT
DO DD^%DT
SET ED=Y
+2 ; *** ELIG DATE **
SET AR(1)=ED
+3 ; *** calc elig CODE
SET AR(2)=EL
End DoDot:1
+4 ;SHW=1 to show calc'd values for TESTING ONLY
if $GET(SHW)
DO SHOW
+5 DO KVAR^VADPT
KILL LD,S0,S1,S2,S6,YY,POP,VAERR
+6 QUIT
+7 ;
ELIGBL ;ELIGIBILITY FOR DISABILITY CONDITION - SC
+1 ;contains DFN,.372,X,0)=31 ptr^disabil %^SC 0/1
+2 ;DIC(31,i,0)= disab txt^abbrev^dx code
+3 ;just 1,2,3,5,7&8 per Kyle 1/14/09
if (+PG<1)
QUIT
IF "123578"'[PG
QUIT
+4 if '$DATA(^DPT(DFN,.372))
QUIT
NEW LD,S,RD,P,AX
SET AX=0
E1 ;*** added IA #174(rated disabilities mult node direct read)
+1 SET AX=$ORDER(^DPT(DFN,.372,AX))
if 'AX
GOTO E1END
+2 IF $DATA(^DPT(DFN,.372,AX,0))
Begin DoDot:1
+3 ;service connected
SET S=^DPT(DFN,.372,AX,0)
IF $PIECE(S,U,3)
Begin DoDot:2
+4 ;disibility file ptr
SET RD=$PIECE(S,U,1)
if RD
Begin DoDot:3
+5 SET X=RD
SET DIC=31
SET DIC(0)="NZ"
DO ^DIC
+6 ;DX codes
SET LD=$SELECT(+Y>0:$PIECE(Y(0),U,3),1:"Unknown")
KILL DIC,Y
+7 ;ck specific hearing DX codes
if +LD<5000
QUIT
if +LD>6300
QUIT
SET LD=+LD
+8 IF (LD=6016)!((LD>6099)&(LD<6111))
SET EL="SC"
QUIT
+9 IF ((LD>6198)&(LD<6212))!((LD>6249)&(LD<6264))
SET EL="SC"
QUIT
+10 IF ((LD>6276)&(LD<6300))
SET EL="SC"
End DoDot:3
End DoDot:2
End DoDot:1
if $LENGTH(EL)
GOTO E1END
+11 ;dis
GOTO E1
E1END QUIT
+1 ;
ALLIED(DFN) ;Determine if qualifying Allied Veteran
+1 ;output: EL= CAN or BRI if true
+2 NEW DIC,DA,DIQ,DR,RM
+3 ; SC
IF $PIECE(VAEL(3),U,1)=1
Begin DoDot:1
+4 SET DIC=2
SET DA=DFN
SET DIQ="RM"
SET DR=".309"
DO EN^DIQ1
+5 if (RM(2,DFN,.309)="CANADA")
SET EL="CAN"
+6 if (RM(2,DFN,.309)["BRITAIN")
SET EL="BRI"
End DoDot:1
+7 QUIT
+8 ;
SHOW ;View data retrieved - for debugging only if SHW=1
+1 ;called from END2
+2 WRITE !!,"Patient: ",$GET(RMDNM)
+3 WRITE !,"Calculated R3 elig = "
if $LENGTH(EL)
WRITE EL
+4 WRITE !,"VA Elig status: "
if $LENGTH(ES)
WRITE ES
+5 WRITE !,"Elig status date: "
if $LENGTH(ED)
WRITE ED
+6 ;W ! ZW AR ;FOR TESTING ONLY
ENDS QUIT
