- RMPFDD2 ;DDC/KAW-SET PATIENT DEMOGRAPHIC/ELIGIBILITY VARIABLES; [ 06/16/95 3:06 PM ]
- ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
- ;; input: DFN
- ;;output: RMPFA,RMPFNAM,RMPFSSN,RMPFTED,RMPFTSD
- ;; RMPFVET,RMPFCL,RMPFDOD,RMPFELG,RMPFELGD,RMPFELS
- ;; RMPFDOB,RMPFELD,RMPFF,RMPFONE,RMPFTE
- S RMPFTE="" G END:'$D(DFN) D PAT^RMPFUTL,ADDRESS,ELIG^VADPT
- S (RMPFCL,RMPFELG,RMPFELGD,RMPFELD,RMPFELS)=""
- S RMPFVET=$S(VAEL(4):"Y",1:"N"),C=1 G ELG2:RMPFVET="N"
- S RMPFCL=VAEL(7) I RMPFCL'="" S RMPFCL=$E(RMPFCL,1,2)_"-"_$E(RMPFCL,3,5)_"-"_$E(RMPFCL,6,8)
- ELIGBL K RMPFF D DISABLE^RMPFUTL S X=0
- 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)
- G E1
- ELG1 K RMPFL S RMPFELG=$P(VAEL(1),U,2) I RMPFELG="" S RMPFELG="UNKNOWN"
- S RMPFELS=$P(VAEL(8),U,2)
- 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
- ELG2 D SVC^VADPT,MB^VADPT,SUB
- END K C,D,I,N,P,S,T,Z,DD,X,Y,%DT,S0,S1,S2,S6,ST,YY,DOB,SSN,POP,RMPFL
- K VAROOT,VAEL,VASV,VAMB,VA,VAERR Q
- ADDRESS ;;Determine patient address
- ;; input:DFN
- ;;output:RMPFA,RMPFTSD,RMPFTED,RMPFONE
- S C=1 K RMPFA D ADD^VADPT
- F I=1:1:3 S P=VAPA(I) I P'="" S RMPFA(C)=P,C=C+1
- S T=VAPA(4),X=$P(VAPA(5),U,1),Z=VAPA(6) S:T'="" T=T_", "
- S S="" I X S S=$S($D(^DIC(5,X,0)):$P(^(0),U,2),1:"")
- S RMPFA(C)=T_S_" "_Z
- S RMPFTSD=$P(VAPA(9),U,2),RMPFTED=$P(VAPA(10),U,2)
- S RMPFONE=$P(VAPA(8),U,1)
- K VAPA,C,I,P,S,T,X,Z,VAERR Q
- 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=""
- E S YY=""
- Q
- SUB ;;Eligibility determinations
- ;; input: DFN,C,VAEL,VASV,VAMB,RMPFTE
- ;;output: RMPFF
- Q:'$D(DFN) Q:'DFN
- 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
- K IX,XX,ZZ,VASV,VAEL,VAMB,Y,VAERR,YY,C,I,X,Y Q
- 1 ;;SERVICE CONNECTED 50% to 100%
- 2 ;;PRISONER OF WAR;I VASV(4) S RMPFF(C)="PRISONER OF WAR",RMPFTE=RMPFF(C)_U_0,C=C+1,YY=""
- 3 ;;MEXICAN BORDER WAR
- 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=""
- 5 ;;AID & ATTENDANCE;I VAMB(1)'=0 S RMPFF(C)="AID & ATTENDANCE",RMPFTE=RMPFF(C)_U_0,C=C+1,YY=""
- 6 ;;HOUSEBOUND;I VAMB(2)'=0 S RMPFF(C)="HOUSEBOUND",RMPFTE=RMPFF(C)_U_0,C=C+1,YY=""
- 7 ;;ALLIED VETERAN;D ALLIED^RMPFDD2
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFDD2 2674 printed Feb 19, 2025@00:02:14 Page 2
- RMPFDD2 ;DDC/KAW-SET PATIENT DEMOGRAPHIC/ELIGIBILITY VARIABLES; [ 06/16/95 3:06 PM ]
- +1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
- +2 ;; input: DFN
- +3 ;;output: RMPFA,RMPFNAM,RMPFSSN,RMPFTED,RMPFTSD
- +4 ;; RMPFVET,RMPFCL,RMPFDOD,RMPFELG,RMPFELGD,RMPFELS
- +5 ;; RMPFDOB,RMPFELD,RMPFF,RMPFONE,RMPFTE
- +6 SET RMPFTE=""
- if '$DATA(DFN)
- GOTO END
- DO PAT^RMPFUTL
- DO ADDRESS
- DO ELIG^VADPT
- +7 SET (RMPFCL,RMPFELG,RMPFELGD,RMPFELD,RMPFELS)=""
- +8 SET RMPFVET=$SELECT(VAEL(4):"Y",1:"N")
- SET C=1
- if RMPFVET="N"
- GOTO ELG2
- +9 SET RMPFCL=VAEL(7)
- IF RMPFCL'=""
- SET RMPFCL=$EXTRACT(RMPFCL,1,2)_"-"_$EXTRACT(RMPFCL,3,5)_"-"_$EXTRACT(RMPFCL,6,8)
- ELIGBL KILL RMPFF
- DO DISABLE^RMPFUTL
- SET X=0
- E1 SET X=$ORDER(^DPT(DFN,.372,X))
- if 'X
- GOTO ELG1
- IF $DATA(^(X,0))
- SET ST=^(0)
- IF $PIECE(ST,U,3)
- SET D=$PIECE(ST,U,1)
- IF D
- IF $DATA(RMPFL(D))
- SET DD=$PIECE(^DIC(31,D,0),U,1)
- SET P=$PIECE(ST,U,2)
- SET RMPFF(C)="SC FOR "_DD
- SET C=C+1
- SET RMPFTE="SC FOR CONDITION"_U_0
- KILL RMPFL(D)
- +1 GOTO E1
- ELG1 KILL RMPFL
- SET RMPFELG=$PIECE(VAEL(1),U,2)
- IF RMPFELG=""
- SET RMPFELG="UNKNOWN"
- +1 SET RMPFELS=$PIECE(VAEL(8),U,2)
- +2 SET (RMPFELGD,RMPFELD)=""
- IF RMPFELS?1"V".E
- IF $DATA(^DPT(DFN,.361))
- SET RMPFELD=$PIECE(^(.361),U,2)
- IF RMPFELD
- SET Y=RMPFELD
- DO DD^%DT
- SET RMPFELGD=Y
- ELG2 DO SVC^VADPT
- DO MB^VADPT
- DO SUB
- END KILL C,D,I,N,P,S,T,Z,DD,X,Y,%DT,S0,S1,S2,S6,ST,YY,DOB,SSN,POP,RMPFL
- +1 KILL VAROOT,VAEL,VASV,VAMB,VA,VAERR
- QUIT
- ADDRESS ;;Determine patient address
- +1 ;; input:DFN
- +2 ;;output:RMPFA,RMPFTSD,RMPFTED,RMPFONE
- +3 SET C=1
- KILL RMPFA
- DO ADD^VADPT
- +4 FOR I=1:1:3
- SET P=VAPA(I)
- IF P'=""
- SET RMPFA(C)=P
- SET C=C+1
- +5 SET T=VAPA(4)
- SET X=$PIECE(VAPA(5),U,1)
- SET Z=VAPA(6)
- if T'=""
- SET T=T_", "
- +6 SET S=""
- IF X
- SET S=$SELECT($DATA(^DIC(5,X,0)):$PIECE(^(0),U,2),1:"")
- +7 SET RMPFA(C)=T_S_" "_Z
- +8 SET RMPFTSD=$PIECE(VAPA(9),U,2)
- SET RMPFTED=$PIECE(VAPA(10),U,2)
- +9 SET RMPFONE=$PIECE(VAPA(8),U,1)
- +10 KILL VAPA,C,I,P,S,T,X,Z,VAERR
- QUIT
- ALLIED IF $DATA(^DPT(DFN,.3))
- SET X=$PIECE(^(.3),U,9)
- IF X
- IF $DATA(^DIC(35,X,0))
- SET X=$PIECE(^(0),U,1)
- IF X["CANADA"!(X["UK GRT BRITAIN")
- SET RMPFF(C)=XX_$SELECT(X["CANADA":" - CANADA",1:" - GREAT BRITAIN")
- SET RMPFTE=RMPFF(C)_U_0
- SET C=C+1
- SET YY=""
- +1 IF '$TEST
- SET YY=""
- +2 QUIT
- SUB ;;Eligibility determinations
- +1 ;; input: DFN,C,VAEL,VASV,VAMB,RMPFTE
- +2 ;;output: RMPFF
- +3 if '$DATA(DFN)
- QUIT
- if 'DFN
- QUIT
- +4 FOR IX=1:1:7
- SET XX=$PIECE($TEXT(@IX),";",3)
- SET ZZ=$PIECE($TEXT(@IX),";",4)
- SET YY=$ORDER(^DIC(8,"B",XX,0))
- if ZZ'=""
- XECUTE ZZ
- IF YY
- IF $PIECE(VAEL(1),U,1)=YY!($DATA(VAEL(1,YY)))
- SET RMPFF(C)=XX
- SET C=C+1
- if RMPFTE=""
- SET RMPFTE=XX_U_0
- +5 KILL IX,XX,ZZ,VASV,VAEL,VAMB,Y,VAERR,YY,C,I,X,Y
- QUIT
- 1 ;;SERVICE CONNECTED 50% to 100%
- 2 ;;PRISONER OF WAR;I VASV(4) S RMPFF(C)="PRISONER OF WAR",RMPFTE=RMPFF(C)_U_0,C=C+1,YY=""
- 3 ;;MEXICAN BORDER WAR
- 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=""
- 5 ;;AID & ATTENDANCE;I VAMB(1)'=0 S RMPFF(C)="AID & ATTENDANCE",RMPFTE=RMPFF(C)_U_0,C=C+1,YY=""
- 6 ;;HOUSEBOUND;I VAMB(2)'=0 S RMPFF(C)="HOUSEBOUND",RMPFTE=RMPFF(C)_U_0,C=C+1,YY=""
- 7 ;;ALLIED VETERAN;D ALLIED^RMPFDD2
