| 1 | RMPFPOSU ;DDC/KAW-CONTINUATION OF RMPFPOST [ 06/16/95 3:06 PM ]
|
|---|
| 2 | ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
|
|---|
| 3 | ORDER S X=$O(^DIC(9.4,"B","REMOTE ORDER/ENTRY SYSTEM",0)) G EXIT:'X
|
|---|
| 4 | W !!,"Updating old orders" K RMPF
|
|---|
| 5 | F I="DEAF/U","DEAF/B" S RMPF($P(I,"/",2))=$O(^RMPR(662,"B",I,0))
|
|---|
| 6 | S RMPFX=0
|
|---|
| 7 | O1 S RMPFX=$O(^RMPF(791810,RMPFX))
|
|---|
| 8 | G EXIT:'RMPFX,O1:'$D(^RMPF(791810,RMPFX,0)) S S0=^(0) W "."
|
|---|
| 9 | S RMPFST=$P(S0,U,3),RMPFSD=$P(S0,U,6)
|
|---|
| 10 | S:RMPFST="" RMPFST=1
|
|---|
| 11 | I RMPFSD="" S RMPFSD=$P(S0,U,1),DIE="^RMPF(791810,",DA=RMPFX,DR=".06////"_RMPFSD D ^DIE
|
|---|
| 12 | S ^RMPF(791810,"AD",9999999.9999-RMPFSD,RMPFX)=""
|
|---|
| 13 | S RMPFTYP=$P(S0,U,2),RMPFTP=""
|
|---|
| 14 | 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
|
|---|
| 15 | .S RMPFST=17,DA=RMPFX,DIE="^RMPF(791810,",DR=".03////"_RMPFST D ^DIE
|
|---|
| 16 | 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
|
|---|
| 17 | I RMPFTYP,$D(^RMPF(791810.1,RMPFTYP,0)) S RMPFTP=$P(^(0),U,3)
|
|---|
| 18 | S:$P(^RMPF(791810,RMPFX,0),U,15)="" $P(^RMPF(791810,RMPFX,0),U,15)=1 ;;Add menu pointer
|
|---|
| 19 | S:$P($G(^RMPF(791810,RMPFX,10)),U,5)="" $P(^RMPF(791810,RMPFX,10),U,5)="R" ;;Add delivery category
|
|---|
| 20 | I RMPFTP="P" D
|
|---|
| 21 | .S RMPFDC=$P($G(^RMPF(791810,RMPFX,2)),U,1)
|
|---|
| 22 | .I RMPFDC="" S RMPFDC="B"
|
|---|
| 23 | .I 'RMPFDC S RMPFDC=$G(RMPF(RMPFDC)) S:RMPFDC="" RMPFDC=44
|
|---|
| 24 | .S $P(^RMPF(791810,RMPFX,2),U,1)=RMPFDC
|
|---|
| 25 | .S DFN=$P(^RMPF(791810,RMPFX,0),U,4) D ELIGBL:DFN'=""
|
|---|
| 26 | S RMPFY=0
|
|---|
| 27 | O2 S RMPFY=$O(^RMPF(791810,RMPFX,101,RMPFY)) G O1:'RMPFY S S1=$G(^(RMPFY,0))
|
|---|
| 28 | I $P(S1,U,17)="" S $P(^RMPF(791810,RMPFX,101,RMPFY,0),U,17)=RMPFSD
|
|---|
| 29 | I $P(S1,U,18)="" S $P(^RMPF(791810,RMPFX,101,RMPFY,0),U,18)=RMPFST
|
|---|
| 30 | 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
|
|---|
| 31 | I $P(S1,U,20)="" S $P(^RMPF(791810,RMPFX,101,RMPFY,0),U,20)=1
|
|---|
| 32 | G O2
|
|---|
| 33 | EXIT W !!,"POST-INIT COMPLETE"
|
|---|
| 34 | K X,DA,DIE,DR,D0,DG,DQ,DI,DIC,D,AB,XY,RMPFX,RMPFST,RMPFTYP,RMPFTP
|
|---|
| 35 | K RMPFDC,RMPF,SD,DD,DFN,IY,LA,P,RMPFF,RMPFL,RMPFSD,RMPFTE,RMPFY,S0,S1
|
|---|
| 36 | K ST,VAEL,VAMB,VAERR,VASV,YY
|
|---|
| 37 | END Q
|
|---|
| 38 | ELIGBL D DISABLE^RMPFUTL,ELIG^VADPT,SVC^VADPT,MB^VADPT S X=0,RMPFTE=""
|
|---|
| 39 | 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
|
|---|
| 40 | G E1
|
|---|
| 41 | ELG1 D SUB S:RMPFTE="" RMPFTE=1
|
|---|
| 42 | ELGE S $P(^RMPF(791810,RMPFX,2),U,2)=RMPFTE Q
|
|---|
| 43 | SUB ;; input: DFN,C,VAEL,VASV,VAMB
|
|---|
| 44 | ;;output: RMPFF
|
|---|
| 45 | Q:'$D(DFN) Q:'DFN S C=0
|
|---|
| 46 | S ST="2;3;4;5;6;7;16;9"
|
|---|
| 47 | K RMPF F IY=1:1:7 S XX=$P($T(@IY),";",3) S RMPF(XX)=$P(ST,";",IY)
|
|---|
| 48 | 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
|
|---|
| 49 | K IX,XX,ZZ,Y,C,I,X,Y Q
|
|---|
| 50 | 1 ;;SERVICE CONNECTED 50% to 100%
|
|---|
| 51 | 2 ;;PRISONER OF WAR;I VASV(4) S RMPFTE=3,YY=""
|
|---|
| 52 | 3 ;;MEXICAN BORDER WAR
|
|---|
| 53 | 4 ;;WORLD WAR I;I $P(VAEL(2),U,2)="WORLD WAR I" S RMPFTE=5,YY=""
|
|---|
| 54 | 5 ;;AID & ATTENDANCE;I VAMB(1)'=0 S RMPFTE=6,YY=""
|
|---|
| 55 | 6 ;;HOUSEBOUND;I VAMB(2)'=0 S RMPFTE=7,YY=""
|
|---|
| 56 | 7 ;;ALLIED VETERAN;D ALLIED^RMPFDD2 I RMPFTE["ALLIED VETERAN" S RMPFTE=8
|
|---|
