57 lines
3.1 KiB
Mathematica
57 lines
3.1 KiB
Mathematica
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
|