RMPFPOSU ;DDC/KAW-CONTINUATION OF RMPFPOST [ 06/16/95   3:06 PM ]
 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
ORDER S X=$O(^DIC(9.4,"B","REMOTE ORDER/ENTRY SYSTEM",0)) G EXIT:'X
 W !!,"Updating old orders" K RMPF
 F I="DEAF/U","DEAF/B" S RMPF($P(I,"/",2))=$O(^RMPR(662,"B",I,0))
 S RMPFX=0
O1 S RMPFX=$O(^RMPF(791810,RMPFX))
 G EXIT:'RMPFX,O1:'$D(^RMPF(791810,RMPFX,0)) S S0=^(0) W "."
 S RMPFST=$P(S0,U,3),RMPFSD=$P(S0,U,6)
 S:RMPFST="" RMPFST=1
 I RMPFSD="" S RMPFSD=$P(S0,U,1),DIE="^RMPF(791810,",DA=RMPFX,DR=".06////"_RMPFSD D ^DIE
 S ^RMPF(791810,"AD",9999999.9999-RMPFSD,RMPFX)=""
 S RMPFTYP=$P(S0,U,2),RMPFTP=""
 I RMPFTYP=2,RMPFST=5!(RMPFST=4),$P(S0,U,15)="" S DIE="^RMPF(791810,",DA=RMPFX,DR=".02///CUSTOM HEARING AID ISSUE" D ^DIE S RMPFTYP=$P(^RMPF(791810,RMPFX,0),U,2) I RMPFST=5 D
 .S RMPFST=17,DA=RMPFX,DIE="^RMPF(791810,",DR=".03////"_RMPFST D ^DIE
 I "51"[RMPFTYP S X=$G(^RMPF(791810,RMPFX,10)) I $P(X,U,8)="" S Y=$P(X,U,4) S:Y="" Y=RMPFSD S $P(^RMPF(791810,RMPFX,10),U,8)=Y ;;Add Audiological Assessment Date
 I RMPFTYP,$D(^RMPF(791810.1,RMPFTYP,0)) S RMPFTP=$P(^(0),U,3)
 S:$P(^RMPF(791810,RMPFX,0),U,15)="" $P(^RMPF(791810,RMPFX,0),U,15)=1 ;;Add menu pointer
 S:$P($G(^RMPF(791810,RMPFX,10)),U,5)="" $P(^RMPF(791810,RMPFX,10),U,5)="R" ;;Add delivery category
 I RMPFTP="P" D
 .S RMPFDC=$P($G(^RMPF(791810,RMPFX,2)),U,1)
 .I RMPFDC="" S RMPFDC="B"
 .I 'RMPFDC S RMPFDC=$G(RMPF(RMPFDC)) S:RMPFDC="" RMPFDC=44
 .S $P(^RMPF(791810,RMPFX,2),U,1)=RMPFDC
 .S DFN=$P(^RMPF(791810,RMPFX,0),U,4) D ELIGBL:DFN'=""
 S RMPFY=0
O2 S RMPFY=$O(^RMPF(791810,RMPFX,101,RMPFY)) G O1:'RMPFY S S1=$G(^(RMPFY,0))
 I $P(S1,U,17)="" S $P(^RMPF(791810,RMPFX,101,RMPFY,0),U,17)=RMPFSD
 I $P(S1,U,18)="" S $P(^RMPF(791810,RMPFX,101,RMPFY,0),U,18)=RMPFST
 I $P(S1,U,19)="" S LA=$S(RMPFTYP=2&(RMPFST=8):"I",1:"O"),$P(^RMPF(791810,RMPFX,101,RMPFY,0),U,19)=LA
 I $P(S1,U,20)="" S $P(^RMPF(791810,RMPFX,101,RMPFY,0),U,20)=1
 G O2
EXIT W !!,"POST-INIT COMPLETE"
 K X,DA,DIE,DR,D0,DG,DQ,DI,DIC,D,AB,XY,RMPFX,RMPFST,RMPFTYP,RMPFTP
 K RMPFDC,RMPF,SD,DD,DFN,IY,LA,P,RMPFF,RMPFL,RMPFSD,RMPFTE,RMPFY,S0,S1
 K ST,VAEL,VAMB,VAERR,VASV,YY
END Q
ELIGBL D DISABLE^RMPFUTL,ELIG^VADPT,SVC^VADPT,MB^VADPT S X=0,RMPFTE=""
E1 S X=$O(^DPT(DFN,.372,X)) G ELGE:RMPFTE'="",ELG1:'X I $D(^(X,0)) S ST=^(0),D=$P(ST,U,1) I D,$D(RMPFL(D)) S DD=$P(^DIC(31,D,0),U,1),P=$P(ST,U,2),RMPFTE=1
 G E1
ELG1 D SUB S:RMPFTE="" RMPFTE=1
ELGE S $P(^RMPF(791810,RMPFX,2),U,2)=RMPFTE Q
SUB ;; input: DFN,C,VAEL,VASV,VAMB
 ;;output: RMPFF
 Q:'$D(DFN)  Q:'DFN  S C=0
 S ST="2;3;4;5;6;7;16;9"
 K RMPF F IY=1:1:7 S XX=$P($T(@IY),";",3) S RMPF(XX)=$P(ST,";",IY)
 F IX=1:1:7 Q:RMPFTE'=""  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 RMPFTE=RMPF(XX) Q
 K IX,XX,ZZ,Y,C,I,X,Y Q
1 ;;SERVICE CONNECTED 50% to 100%
2 ;;PRISONER OF WAR;I VASV(4) S RMPFTE=3,YY=""
3 ;;MEXICAN BORDER WAR
4 ;;WORLD WAR I;I $P(VAEL(2),U,2)="WORLD WAR I" S RMPFTE=5,YY=""
5 ;;AID & ATTENDANCE;I VAMB(1)'=0 S RMPFTE=6,YY=""
6 ;;HOUSEBOUND;I VAMB(2)'=0 S RMPFTE=7,YY=""
7 ;;ALLIED VETERAN;D ALLIED^RMPFDD2 I RMPFTE["ALLIED VETERAN" S RMPFTE=8