source: WorldVistAEHR/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFET4.m@ 1806

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

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1RMPFET4 ;DDC/KAW-EVALUATE ORDER STATUS BY TYPE [ 05/27/95 2:10 PM ]
2 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**20**;MAY 30, 1995
3CUST ;; input: RMPFX
4 ;;output: RMPFERR,RMPFMSG
5 S SS=$S($D(^RMPF(791810,RMPFX,11)):^(11),1:"")
6 S RMPFTF=$P(SS,U,1),RMPFUS=$P(SS,U,2)
7 S RMPFDC=$P($G(^RMPF(791810,RMPFX,2)),U,1) I RMPFDC,$D(^RMPR(662,RMPFDC,0)) S X=$P(^(0),U,1) D
8 .I X["DEAF/U",RMPFTF="B" S RMPFERR("FITTING CANNOT BE BINAURAL IF PATIENT IS DEAF/U")=""
9 .I X["DEAF/U",RMPFUS="B" S RMPFERR("PATIENT CANNOT BE AUTHORIZED FOR BINAURAL USE IF DISABILITY IS DEAF/U")=""
10 D ARRAY^RMPFDT2 S (X,CX)=0 K RMPFEAR
11 F I=1:1 S X=$O(RMPFO(X)) Q:'X S CX=CX+1,A=$P(^RMPF(791810,RMPFX,101,X,0),U,4) I A'="" D
12 .S IT=$P(^RMPF(791810,RMPFX,101,X,0),U,1) Q:'IT
13 .Q:'$D(^RMPF(791811,IT,0))
14 .Q:$P(^RMPF(791811,IT,0),"^",1)["REMOTE"
15 .I $D(RMPFEAR(A)) S RMPFMSG("TWO OR MORE AIDS ARE ORDERED FOR THE SAME EAR")=""
16 .S RMPFEAR(A)="" Q
17 I RMPFTF="B",CX<2 S RMPFERR("TWO AIDS MUST BE ORDERED WITH A BINAURAL FITTING")=""
18 I RMPFUS="M",RMPFTF="B" S RMPFERR("FITTING CANNOT BE BINAURAL IF AUTHORIZED USAGE IS MONAURAL")=""
19 I RMPFUS="M",CX>2 S RMPFMSG("MORE THAN TWO AIDS HAVE BEEN ORDERED FOR A MONAURAL USER")=""
20 S SS=$G(^RMPF(791810,RMPFX,10)),RC=$P(SS,U,4),AD=$P(SS,U,8)
21 I RC>DT S RMPFERR("REQUEST FOR CARE DATE CANNOT BE A FUTURE DATE")=""
22 I AD>DT S RMPFERR("AUDIOLOGICAL ASSESSMENT DATE CANNOT BE A FUTURE DATE")=""
23 I AD,RC>AD S RMPFERR("AUDIOLOGICAL ASSESSMENT DATE CANNOT BE PRIOR TO REQUEST FOR CARE DATE")=""
24 K SS,RMPFDC,RMPFO,RMPFTF,RMPFUS,RMPFEAR,I,X,CX,A,RC,AD,IT Q
25REG ;; input: RMPFX
26 ;;output: RMPFERR
27 S X=0
28 F I=1:1 S X=$O(^RMPF(791810,RMPFX,101,X)) G REGE:'X D
29 .Q:'$D(^RMPF(791810,RMPFX,101,X,0)) Q:$P(^(0),U,1)'=1
30 .I '$D(^RMPF(791810,RMPFX,101,X,2)) S RMPFERR("FREE TEXT MAKE AND MODEL NOT ENTERED")=""
31 .S MM=$G(^RMPF(791810,RMPFX,101,X,2)) S MK=$P(MM,U,1) I MK="" S RMPFERR("FREE TEXT MAKE MISSING")=""
32 .S MD=$P(MM,U,2) I MD="" S RMPFERR("FREE TEXT MODEL MISSING")=""
33 .Q
34REGE K X,I,MM,MK,MD Q
35ISS ;;Special error checks for Custom Hearing Aid Issue Orders
36 ;; input: RMPFX
37 ;;output: RMPFERR
38 S OD=$P(^RMPF(791810,RMPFX,0),U,9) D ARRAY^RMPFDT2 S RMPFY=0
39I1 F S RMPFY=$O(RMPFO(RMPFY)) Q:'RMPFY D
40 .Q:'$D(^RMPF(791810,RMPFX,101,RMPFY)) S S0=^(RMPFY,0) Q:$P(S0,U,15)="C"
41 .I $P(S0,U,20),$P(S0,U,19)["R" D
42 ..I $P(S0,U,5)="" S RMPFERR("SERIAL NUMBER MISSING")=""
43 ..S X=$G(^RMPF(791810,RMPFX,101,RMPFY,90))
44 ..I $P(X,U,8)=""!($P(X,U,9)="") S RMPFERR("CERTIFICATION INFORMATION MISSING")=""
45 .S ID=$P(S0,U,8),X=$P(S0,U,19),BT=$P(S0,U,2)
46 .I BT="",$P($G(^RMPF(791810,RMPFX,101,RMPFY,90)),U,8),'$P(^(0),U,20),$P(^(0),U,19)["I" S RMPFERR("BATTERY TYPE MISSING")=""
47 .I X["I",$P($G(^RMPF(791810,RMPFX,101,RMPFY,90)),U,12)="" S RMPFERR("ISSUING USER MISSING")=""
48 .I ID="",X["I" S RMPFERR("ISSUE DATE MISSING")="" Q
49 .Q:ID=""
50 .I ID<OD S RMPFERR("ISSUE DATE IS PRIOR TO ORDER DATE")=""
51ISSE K OD,ID,BT,S0,RMPFY,X,RMPFO Q
Note: See TracBrowser for help on using the repository browser.