160 lines
7.6 KiB
Mathematica
160 lines
7.6 KiB
Mathematica
RMPFRPC0 ;DDC/PJU - Module to establish DDC elig for ROES3 ;7/14/04
|
|
;;3.0;REMOTE ORDER/ENTRY SYSTEM;**1**;11/1/02
|
|
START(AR,DFN,SHW) ;called from RPC RMPFELIG
|
|
;;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
|
|
;created during calculation in the AR array (passed by reference)
|
|
;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)/DISAPPR(0)/submit(2)^PSAS user^ASPS user^req dt^sug el^act dt
|
|
;PS = enrollment group sub
|
|
;R3 = array of auto accepted R3 elig's
|
|
K AR ;in case came in with data (is called by ref)
|
|
N ROES ;array of eligibilities to submitted to PSAS
|
|
N N ED,EL,ES,FL,ER,PD,PE,PG,PS,R3,RA,SR,SSN,VS,VT,IEN
|
|
S (ED,EL,ES,FL,ER,PD,PE,PG,PS,R3,RA,SR,SSN,VS,VT,IEN)=""
|
|
F X=0:1:8 S AR(X)="" ;re-establish AR
|
|
F X="SC","COM","EP3","POW","AAA","HB","CAN","BRI","WWI" S R3(X)="" ;no PSAS ap needed
|
|
D K VADM,VAEL,VAMB,VAPA,VASV
|
|
D DEM^VADPT ;sets up VADM() - demographic variables *** ck for errors
|
|
I $G(VAERR) S ER="**ERROR** Problem in retrieving Demographic values" G END
|
|
I $G(VADM(6)) D
|
|
.S (PD,AR(0))=VADM(6) ;fm^external date of death
|
|
S SSN=$P($G(VADM(2)),U,1)
|
|
;*** ADDED TO Integration agreement 767 NAME: DBIA268-C SEN REC ***
|
|
I $P($G(^DGSL(38.1,DFN,0)),U,2) S AR(4)=1 ;ck for sensitive record
|
|
S VAPA("P")="" D ADD^VADPT ;get permanent address
|
|
I $G(VAERR) S ER="**ERROR** Problem in retrieving Permanent Address" G END
|
|
E D ELIG^VADPT ;sets up VAEL() - eligibility variables & ck for errors
|
|
I $G(VAERR) D G END
|
|
.S ER="**ERROR** Problem in retrieving Eligibility from ELIG^VADPT"
|
|
I $L(ER) G END
|
|
S (PE,AR(6))=$P($G(VAEL(1)),U,2) ;external form of PRIMARY ELIG
|
|
S ES=$P($G(VAEL(8)),U,1) ;elig status
|
|
I ES="V" D
|
|
.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
|
|
S VT=$S($G(VAEL(4)):"Y",1:"N") ;VET Y/N
|
|
I VT="Y" D ;G:$L(EL) END ;11/19/03 need PG for ALL
|
|
.D ELIGBL Q:$L(EL) ; checks for SC for condition SC
|
|
.S VS=$G(VAEL(3)) I $P(VS,U,1) D ;VAEL(3)=0/1 for SC ^ %
|
|
..I $P(VS,U,2)'<10 S EL="COM" ;SC 10% or greater COM
|
|
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 patient file
|
|
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:"") ;Priority Subgroup
|
|
K RM,RM2,DIC,DA,DIQ,DR,PS1
|
|
G:$L(EL) END ;11/19/03 now can go to end if know EL
|
|
I VT="Y",PG=3 D G:$L(EL) END
|
|
.S EL="EP3" ; EP3
|
|
D SVC^VADPT I $G(VAERR) D G END
|
|
.S ER="**ERROR** Problem in retrieving Service Information(SVC^VADPT)"
|
|
I ($G(VASV(4))=1)!($P(VAEL(1),U,2)="PRISONER OF WAR") D G:$L(EL) END
|
|
.S EL="POW" ; POW
|
|
D MB^VADPT I $G(VAERR) D G END
|
|
.S ER="**ERROR** Problem in retrieving Benefit information(MB^VADPT)"
|
|
; VAEL(1)=#^PRIMARY ELIG
|
|
I VT="Y" D G:$L(EL) END
|
|
.I $G(VAMB(1))!($P(VAEL(1),U,2)="AID & ATTENDANCE") S EL="AAA" Q ; AAA **PRI ELIG
|
|
.I $G(VAMB(2))!($P(VAEL(1),U,2)="HOUSEBOUND") S EL="HB" Q ; HB **
|
|
.I $G(VAEL(3)),$P($G(VAEL(3)),U,2)=0 D Q:$L(EL) ; 0CA
|
|
..I PG=5 S EL="0CA" Q
|
|
..I PG=7,PS="A" S EL="0CA"
|
|
.I PG=5 D Q:$L(EL) ; NCA**
|
|
..I $P($G(VAEL(1)),U,2)="NSC, VA PENSION" S EL="NCA" Q ;PG5 NSC, VA PENSION primary eligibility
|
|
..I $P($G(VAEL(6)),U,2)="NSC VETERAN" S EL="NCA" Q ;PG 5 NSC Veteran
|
|
.;I PG=6 S EL="SCV" Q ;Special category veterans SCV
|
|
.I ($P($G(VAEL(2)),U,2)="WORLD WAR I")!($P($G(VAEL(2)),U,2)="MEXICAN BORDER WAR") D
|
|
..S EL="WWI" ; WWI
|
|
G:$L(EL) END
|
|
D ALLIED(DFN) G:$L(EL) END ; CAN or BRI
|
|
S X=0 D:($D(VAEL(1))>9) 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)&(PS="C") 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
|
|
;CK FOR ACCEPTANCE OR REJECTION
|
|
S IEN="" I $D(^RMPF(791814,"B",DFN)) D
|
|
.S IEN=$O(^RMPF(791814,"B",DFN," "),-1)
|
|
G:'IEN END2
|
|
I (EL="")!(EL="NSC")!(EL="BLR")!(EL="VOC")!(EL="OGA")!(EL="PG8")!(EL="NCA")!(EL="0CA") D
|
|
.S RA=$P($G(^RMPF(791814,IEN,2)),U,2) ;0 or 1 or 2
|
|
.S:RA="" RA=2 ;submitted, but not acted on
|
|
.S EL=$S(RA=1:$P($G(^RMPF(791814,IEN,2)),U,1),1:EL),AR(2)=EL ;appr elig code or CALC
|
|
.S X=$P($G(^RMPF(791814,IEN,2)),U,3),Y="Unknown" ;PSAS user DUZ
|
|
.I X>0 S DIC=200,DIC(0)="N" D ^DIC D
|
|
..S Y=$S(+Y>0:$P(Y,U,2),1:"Unknown") K DIC
|
|
..S $P(RA,U,2)=Y ;name of PSAS user
|
|
.S X=$P($G(^RMPF(791814,IEN,0)),U,3),Y="Unknown" ;ASPS user DUZ
|
|
.I X>0 S DIC=200,DIC(0)="N" D ^DIC D
|
|
..S Y=$S(+Y>0:$P(Y,U,2),1:"Unknown") K DIC
|
|
..S $P(RA,U,3)=Y ;name of ASPS user
|
|
.S:$L(RA) AR(8)=EL_U_RA ;elg^0/1/2^PSAS user^ASPS user name
|
|
.S Y=$P(^RMPF(791814,IEN,0),U,2) D DD^%DT ;ret Y=date of req
|
|
.S $P(AR(8),U,5)=Y ;elg^0/1/2^PSAS user ^ASPS user name^dt req ent
|
|
.I $D(^RMPF(791814,IEN,1)) D
|
|
..S $P(AR(8),U,6)=$P(^RMPF(791814,IEN,1),U,1) ;sugg elig
|
|
.I $D(^RMPF(791814,IEN,2)) D
|
|
..S Y=$P(^RMPF(791814,IEN,2),U,4) D:$L(Y) DD^%DT
|
|
..S $P(AR(8),U,7)=Y ;Action date
|
|
END2 D:$G(SHW) SHOW ; show calc'd values for testing
|
|
D KVAR^VADPT K LD,S0,S1,S2,S6,YY,POP
|
|
Q
|
|
ELIGBL ;ELIGIBILITY FOR DISABILITY CONDITION
|
|
;contains DFN,.372,X,0)=31 ptr^disabil %^SC 0/1
|
|
;DIC(31,i,0)= disab txt^abbrev^dx code
|
|
N LD,S,RD,P,AX S AX=0
|
|
E1 ;*** added to IA #174 for rated disabilities multiple 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
|
|
...Q:+LD<5000 Q:+LD>6300 S LD=+LD ;ck hearing loss DX codes/ck on codes 6259 & 6298
|
|
...I (LD=6016)!((LD>6099)&(LD<6111)) S EL="SC" Q
|
|
...I ((LD>6198)&(LD<6212))!((LD>6249)&(LD<6264)) S EL="SC" Q ; SC for condition
|
|
...I ((LD>6276)&(LD<6300)) S EL="SC"
|
|
G E1 ;dis
|
|
E1END Q
|
|
;
|
|
SHOW ;all visible prompts if needed FOR TESTING ONLY
|
|
;ZW AR ; for testing
|
|
W !!,"Patient: " I $G(DFN) W $S($D(^DPT(DFN,0)):$P(^(0),U,1),1:DFN)
|
|
I $L(EL) D
|
|
.W !,"Calculated R3 elig = ",EL
|
|
.I '$D(R3(EL)) D
|
|
..W !," ***** ","ROES3 ELIGIBILITY MUST BE APPROVED BY PSAS *****"
|
|
I '$L(EL) D
|
|
.W !," ***** ","ROES3 ELIGIBILITY NOT DETERMINED, ORDER MUST BE APPROVED BY PSAS *****"
|
|
W !,"VA Elig status: "
|
|
I $L(ES) W ES
|
|
E W !," ***** ","NO ELIG STATUS - MUST BE APPROVED BY PSAS *****"
|
|
W !,"Elig status date: " I $L(ED) W ED
|
|
ENDS Q
|
|
;
|
|
ALLIED(DFN) ;;input: DFN
|
|
;;output: EL= CAN or BRI if true
|
|
I $P(VAEL(3),U,1)=1 D ;sc
|
|
.N DIC,DA,DIQ,DR,RM
|
|
.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
|