source: WorldVistAEHR/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFPOSU.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.1 KB
RevLine 
[613]1RMPFPOSU ;DDC/KAW-CONTINUATION OF RMPFPOST [ 06/16/95 3:06 PM ]
2 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
3ORDER 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
7O1 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
27O2 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
33EXIT 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
37END Q
38ELIGBL D DISABLE^RMPFUTL,ELIG^VADPT,SVC^VADPT,MB^VADPT S X=0,RMPFTE=""
39E1 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
41ELG1 D SUB S:RMPFTE="" RMPFTE=1
42ELGE S $P(^RMPF(791810,RMPFX,2),U,2)=RMPFTE Q
43SUB ;; 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
501 ;;SERVICE CONNECTED 50% to 100%
512 ;;PRISONER OF WAR;I VASV(4) S RMPFTE=3,YY=""
523 ;;MEXICAN BORDER WAR
534 ;;WORLD WAR I;I $P(VAEL(2),U,2)="WORLD WAR I" S RMPFTE=5,YY=""
545 ;;AID & ATTENDANCE;I VAMB(1)'=0 S RMPFTE=6,YY=""
556 ;;HOUSEBOUND;I VAMB(2)'=0 S RMPFTE=7,YY=""
567 ;;ALLIED VETERAN;D ALLIED^RMPFDD2 I RMPFTE["ALLIED VETERAN" S RMPFTE=8
Note: See TracBrowser for help on using the repository browser.