| [613] | 1 | RMPFET4 ;DDC/KAW-EVALUATE ORDER STATUS BY TYPE [ 05/27/95 2:10 PM ]
|
|---|
| 2 | ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**20**;MAY 30, 1995
|
|---|
| 3 | CUST ;; 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
|
|---|
| 25 | REG ;; 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
|
|---|
| 34 | REGE K X,I,MM,MK,MD Q
|
|---|
| 35 | ISS ;;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
|
|---|
| 39 | I1 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")=""
|
|---|
| 51 | ISSE K OD,ID,BT,S0,RMPFY,X,RMPFO Q
|
|---|
