| 1 | RMPFDD2 ;DDC/KAW-SET PATIENT DEMOGRAPHIC/ELIGIBILITY VARIABLES; [ 06/16/95 3:06 PM ]
|
|---|
| 2 | ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
|
|---|
| 3 | ;; input: DFN
|
|---|
| 4 | ;;output: RMPFA,RMPFNAM,RMPFSSN,RMPFTED,RMPFTSD
|
|---|
| 5 | ;; RMPFVET,RMPFCL,RMPFDOD,RMPFELG,RMPFELGD,RMPFELS
|
|---|
| 6 | ;; RMPFDOB,RMPFELD,RMPFF,RMPFONE,RMPFTE
|
|---|
| 7 | S RMPFTE="" G END:'$D(DFN) D PAT^RMPFUTL,ADDRESS,ELIG^VADPT
|
|---|
| 8 | S (RMPFCL,RMPFELG,RMPFELGD,RMPFELD,RMPFELS)=""
|
|---|
| 9 | S RMPFVET=$S(VAEL(4):"Y",1:"N"),C=1 G ELG2:RMPFVET="N"
|
|---|
| 10 | S RMPFCL=VAEL(7) I RMPFCL'="" S RMPFCL=$E(RMPFCL,1,2)_"-"_$E(RMPFCL,3,5)_"-"_$E(RMPFCL,6,8)
|
|---|
| 11 | ELIGBL K RMPFF D DISABLE^RMPFUTL S X=0
|
|---|
| 12 | E1 S X=$O(^DPT(DFN,.372,X)) G ELG1:'X I $D(^(X,0)) S ST=^(0) I $P(ST,U,3) S D=$P(ST,U,1) I D,$D(RMPFL(D)) S DD=$P(^DIC(31,D,0),U,1),P=$P(ST,U,2),RMPFF(C)="SC FOR "_DD,C=C+1,RMPFTE="SC FOR CONDITION"_U_0 K RMPFL(D)
|
|---|
| 13 | G E1
|
|---|
| 14 | ELG1 K RMPFL S RMPFELG=$P(VAEL(1),U,2) I RMPFELG="" S RMPFELG="UNKNOWN"
|
|---|
| 15 | S RMPFELS=$P(VAEL(8),U,2)
|
|---|
| 16 | S (RMPFELGD,RMPFELD)="" I RMPFELS?1"V".E,$D(^DPT(DFN,.361)) S RMPFELD=$P(^(.361),U,2) I RMPFELD S Y=RMPFELD D DD^%DT S RMPFELGD=Y
|
|---|
| 17 | ELG2 D SVC^VADPT,MB^VADPT,SUB
|
|---|
| 18 | END K C,D,I,N,P,S,T,Z,DD,X,Y,%DT,S0,S1,S2,S6,ST,YY,DOB,SSN,POP,RMPFL
|
|---|
| 19 | K VAROOT,VAEL,VASV,VAMB,VA,VAERR Q
|
|---|
| 20 | ADDRESS ;;Determine patient address
|
|---|
| 21 | ;; input:DFN
|
|---|
| 22 | ;;output:RMPFA,RMPFTSD,RMPFTED,RMPFONE
|
|---|
| 23 | S C=1 K RMPFA D ADD^VADPT
|
|---|
| 24 | F I=1:1:3 S P=VAPA(I) I P'="" S RMPFA(C)=P,C=C+1
|
|---|
| 25 | S T=VAPA(4),X=$P(VAPA(5),U,1),Z=VAPA(6) S:T'="" T=T_", "
|
|---|
| 26 | S S="" I X S S=$S($D(^DIC(5,X,0)):$P(^(0),U,2),1:"")
|
|---|
| 27 | S RMPFA(C)=T_S_" "_Z
|
|---|
| 28 | S RMPFTSD=$P(VAPA(9),U,2),RMPFTED=$P(VAPA(10),U,2)
|
|---|
| 29 | S RMPFONE=$P(VAPA(8),U,1)
|
|---|
| 30 | K VAPA,C,I,P,S,T,X,Z,VAERR Q
|
|---|
| 31 | ALLIED I $D(^DPT(DFN,.3)) S X=$P(^(.3),U,9) I X,$D(^DIC(35,X,0)) S X=$P(^(0),U,1) I X["CANADA"!(X["UK GRT BRITAIN") S RMPFF(C)=XX_$S(X["CANADA":" - CANADA",1:" - GREAT BRITAIN"),RMPFTE=RMPFF(C)_U_0,C=C+1,YY=""
|
|---|
| 32 | E S YY=""
|
|---|
| 33 | Q
|
|---|
| 34 | SUB ;;Eligibility determinations
|
|---|
| 35 | ;; input: DFN,C,VAEL,VASV,VAMB,RMPFTE
|
|---|
| 36 | ;;output: RMPFF
|
|---|
| 37 | Q:'$D(DFN) Q:'DFN
|
|---|
| 38 | F IX=1:1:7 S XX=$P($T(@IX),";",3),ZZ=$P($T(@IX),";",4),YY=$O(^DIC(8,"B",XX,0)) X:ZZ'="" ZZ I YY,$P(VAEL(1),U,1)=YY!($D(VAEL(1,YY))) S RMPFF(C)=XX,C=C+1 S:RMPFTE="" RMPFTE=XX_U_0
|
|---|
| 39 | K IX,XX,ZZ,VASV,VAEL,VAMB,Y,VAERR,YY,C,I,X,Y Q
|
|---|
| 40 | 1 ;;SERVICE CONNECTED 50% to 100%
|
|---|
| 41 | 2 ;;PRISONER OF WAR;I VASV(4) S RMPFF(C)="PRISONER OF WAR",RMPFTE=RMPFF(C)_U_0,C=C+1,YY=""
|
|---|
| 42 | 3 ;;MEXICAN BORDER WAR
|
|---|
| 43 | 4 ;;WORLD WAR I;I $P(VAEL(2),U,2)="WORLD WAR I" S RMPFF(C)="WORLD WAR I",RMPFTE=RMPFF(C)_U_0,C=C+1,YY=""
|
|---|
| 44 | 5 ;;AID & ATTENDANCE;I VAMB(1)'=0 S RMPFF(C)="AID & ATTENDANCE",RMPFTE=RMPFF(C)_U_0,C=C+1,YY=""
|
|---|
| 45 | 6 ;;HOUSEBOUND;I VAMB(2)'=0 S RMPFF(C)="HOUSEBOUND",RMPFTE=RMPFF(C)_U_0,C=C+1,YY=""
|
|---|
| 46 | 7 ;;ALLIED VETERAN;D ALLIED^RMPFDD2
|
|---|
