RMPFET4 ;DDC/KAW-EVALUATE ORDER STATUS BY TYPE [ 05/27/95 2:10 PM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;**20**;MAY 30, 1995
CUST ;; input: RMPFX
;;output: RMPFERR,RMPFMSG
S SS=$S($D(^RMPF(791810,RMPFX,11)):^(11),1:"")
S RMPFTF=$P(SS,U,1),RMPFUS=$P(SS,U,2)
S RMPFDC=$P($G(^RMPF(791810,RMPFX,2)),U,1) I RMPFDC,$D(^RMPR(662,RMPFDC,0)) S X=$P(^(0),U,1) D
.I X["DEAF/U",RMPFTF="B" S RMPFERR("FITTING CANNOT BE BINAURAL IF PATIENT IS DEAF/U")=""
.I X["DEAF/U",RMPFUS="B" S RMPFERR("PATIENT CANNOT BE AUTHORIZED FOR BINAURAL USE IF DISABILITY IS DEAF/U")=""
D ARRAY^RMPFDT2 S (X,CX)=0 K RMPFEAR
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
.S IT=$P(^RMPF(791810,RMPFX,101,X,0),U,1) Q:'IT
.Q:'$D(^RMPF(791811,IT,0))
.Q:$P(^RMPF(791811,IT,0),"^",1)["REMOTE"
.I $D(RMPFEAR(A)) S RMPFMSG("TWO OR MORE AIDS ARE ORDERED FOR THE SAME EAR")=""
.S RMPFEAR(A)="" Q
I RMPFTF="B",CX<2 S RMPFERR("TWO AIDS MUST BE ORDERED WITH A BINAURAL FITTING")=""
I RMPFUS="M",RMPFTF="B" S RMPFERR("FITTING CANNOT BE BINAURAL IF AUTHORIZED USAGE IS MONAURAL")=""
I RMPFUS="M",CX>2 S RMPFMSG("MORE THAN TWO AIDS HAVE BEEN ORDERED FOR A MONAURAL USER")=""
S SS=$G(^RMPF(791810,RMPFX,10)),RC=$P(SS,U,4),AD=$P(SS,U,8)
I RC>DT S RMPFERR("REQUEST FOR CARE DATE CANNOT BE A FUTURE DATE")=""
I AD>DT S RMPFERR("AUDIOLOGICAL ASSESSMENT DATE CANNOT BE A FUTURE DATE")=""
I AD,RC>AD S RMPFERR("AUDIOLOGICAL ASSESSMENT DATE CANNOT BE PRIOR TO REQUEST FOR CARE DATE")=""
K SS,RMPFDC,RMPFO,RMPFTF,RMPFUS,RMPFEAR,I,X,CX,A,RC,AD,IT Q
REG ;; input: RMPFX
;;output: RMPFERR
S X=0
F I=1:1 S X=$O(^RMPF(791810,RMPFX,101,X)) G REGE:'X D
.Q:'$D(^RMPF(791810,RMPFX,101,X,0)) Q:$P(^(0),U,1)'=1
.I '$D(^RMPF(791810,RMPFX,101,X,2)) S RMPFERR("FREE TEXT MAKE AND MODEL NOT ENTERED")=""
.S MM=$G(^RMPF(791810,RMPFX,101,X,2)) S MK=$P(MM,U,1) I MK="" S RMPFERR("FREE TEXT MAKE MISSING")=""
.S MD=$P(MM,U,2) I MD="" S RMPFERR("FREE TEXT MODEL MISSING")=""
.Q
REGE K X,I,MM,MK,MD Q
ISS ;;Special error checks for Custom Hearing Aid Issue Orders
;; input: RMPFX
;;output: RMPFERR
S OD=$P(^RMPF(791810,RMPFX,0),U,9) D ARRAY^RMPFDT2 S RMPFY=0
I1 F S RMPFY=$O(RMPFO(RMPFY)) Q:'RMPFY D
.Q:'$D(^RMPF(791810,RMPFX,101,RMPFY)) S S0=^(RMPFY,0) Q:$P(S0,U,15)="C"
.I $P(S0,U,20),$P(S0,U,19)["R" D
..I $P(S0,U,5)="" S RMPFERR("SERIAL NUMBER MISSING")=""
..S X=$G(^RMPF(791810,RMPFX,101,RMPFY,90))
..I $P(X,U,8)=""!($P(X,U,9)="") S RMPFERR("CERTIFICATION INFORMATION MISSING")=""
.S ID=$P(S0,U,8),X=$P(S0,U,19),BT=$P(S0,U,2)
.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")=""
.I X["I",$P($G(^RMPF(791810,RMPFX,101,RMPFY,90)),U,12)="" S RMPFERR("ISSUING USER MISSING")=""
.I ID="",X["I" S RMPFERR("ISSUE DATE MISSING")="" Q
.Q:ID=""
.I ID<OD S RMPFERR("ISSUE DATE IS PRIOR TO ORDER DATE")=""
ISSE K OD,ID,BT,S0,RMPFY,X,RMPFO Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFET4 2962 printed Oct 16, 2024@18:37:02 Page 2
RMPFET4 ;DDC/KAW-EVALUATE ORDER STATUS BY TYPE [ 05/27/95 2:10 PM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**20**;MAY 30, 1995
CUST ;; input: RMPFX
+1 ;;output: RMPFERR,RMPFMSG
+2 SET SS=$SELECT($DATA(^RMPF(791810,RMPFX,11)):^(11),1:"")
+3 SET RMPFTF=$PIECE(SS,U,1)
SET RMPFUS=$PIECE(SS,U,2)
+4 SET RMPFDC=$PIECE($GET(^RMPF(791810,RMPFX,2)),U,1)
IF RMPFDC
IF $DATA(^RMPR(662,RMPFDC,0))
SET X=$PIECE(^(0),U,1)
Begin DoDot:1
+5 IF X["DEAF/U"
IF RMPFTF="B"
SET RMPFERR("FITTING CANNOT BE BINAURAL IF PATIENT IS DEAF/U")=""
+6 IF X["DEAF/U"
IF RMPFUS="B"
SET RMPFERR("PATIENT CANNOT BE AUTHORIZED FOR BINAURAL USE IF DISABILITY IS DEAF/U")=""
End DoDot:1
+7 DO ARRAY^RMPFDT2
SET (X,CX)=0
KILL RMPFEAR
+8 FOR I=1:1
SET X=$ORDER(RMPFO(X))
if 'X
QUIT
SET CX=CX+1
SET A=$PIECE(^RMPF(791810,RMPFX,101,X,0),U,4)
IF A'=""
Begin DoDot:1
+9 SET IT=$PIECE(^RMPF(791810,RMPFX,101,X,0),U,1)
if 'IT
QUIT
+10 if '$DATA(^RMPF(791811,IT,0))
QUIT
+11 if $PIECE(^RMPF(791811,IT,0),"^",1)["REMOTE"
QUIT
+12 IF $DATA(RMPFEAR(A))
SET RMPFMSG("TWO OR MORE AIDS ARE ORDERED FOR THE SAME EAR")=""
+13 SET RMPFEAR(A)=""
QUIT
End DoDot:1
+14 IF RMPFTF="B"
IF CX<2
SET RMPFERR("TWO AIDS MUST BE ORDERED WITH A BINAURAL FITTING")=""
+15 IF RMPFUS="M"
IF RMPFTF="B"
SET RMPFERR("FITTING CANNOT BE BINAURAL IF AUTHORIZED USAGE IS MONAURAL")=""
+16 IF RMPFUS="M"
IF CX>2
SET RMPFMSG("MORE THAN TWO AIDS HAVE BEEN ORDERED FOR A MONAURAL USER")=""
+17 SET SS=$GET(^RMPF(791810,RMPFX,10))
SET RC=$PIECE(SS,U,4)
SET AD=$PIECE(SS,U,8)
+18 IF RC>DT
SET RMPFERR("REQUEST FOR CARE DATE CANNOT BE A FUTURE DATE")=""
+19 IF AD>DT
SET RMPFERR("AUDIOLOGICAL ASSESSMENT DATE CANNOT BE A FUTURE DATE")=""
+20 IF AD
IF RC>AD
SET RMPFERR("AUDIOLOGICAL ASSESSMENT DATE CANNOT BE PRIOR TO REQUEST FOR CARE DATE")=""
+21 KILL SS,RMPFDC,RMPFO,RMPFTF,RMPFUS,RMPFEAR,I,X,CX,A,RC,AD,IT
QUIT
REG ;; input: RMPFX
+1 ;;output: RMPFERR
+2 SET X=0
+3 FOR I=1:1
SET X=$ORDER(^RMPF(791810,RMPFX,101,X))
if 'X
GOTO REGE
Begin DoDot:1
+4 if '$DATA(^RMPF(791810,RMPFX,101,X,0))
QUIT
if $PIECE(^(0),U,1)'=1
QUIT
+5 IF '$DATA(^RMPF(791810,RMPFX,101,X,2))
SET RMPFERR("FREE TEXT MAKE AND MODEL NOT ENTERED")=""
+6 SET MM=$GET(^RMPF(791810,RMPFX,101,X,2))
SET MK=$PIECE(MM,U,1)
IF MK=""
SET RMPFERR("FREE TEXT MAKE MISSING")=""
+7 SET MD=$PIECE(MM,U,2)
IF MD=""
SET RMPFERR("FREE TEXT MODEL MISSING")=""
+8 QUIT
End DoDot:1
REGE KILL X,I,MM,MK,MD
QUIT
ISS ;;Special error checks for Custom Hearing Aid Issue Orders
+1 ;; input: RMPFX
+2 ;;output: RMPFERR
+3 SET OD=$PIECE(^RMPF(791810,RMPFX,0),U,9)
DO ARRAY^RMPFDT2
SET RMPFY=0
I1 FOR
SET RMPFY=$ORDER(RMPFO(RMPFY))
if 'RMPFY
QUIT
Begin DoDot:1
+1 if '$DATA(^RMPF(791810,RMPFX,101,RMPFY))
QUIT
SET S0=^(RMPFY,0)
if $PIECE(S0,U,15)="C"
QUIT
+2 IF $PIECE(S0,U,20)
IF $PIECE(S0,U,19)["R"
Begin DoDot:2
+3 IF $PIECE(S0,U,5)=""
SET RMPFERR("SERIAL NUMBER MISSING")=""
+4 SET X=$GET(^RMPF(791810,RMPFX,101,RMPFY,90))
+5 IF $PIECE(X,U,8)=""!($PIECE(X,U,9)="")
SET RMPFERR("CERTIFICATION INFORMATION MISSING")=""
End DoDot:2
+6 SET ID=$PIECE(S0,U,8)
SET X=$PIECE(S0,U,19)
SET BT=$PIECE(S0,U,2)
+7 IF BT=""
IF $PIECE($GET(^RMPF(791810,RMPFX,101,RMPFY,90)),U,8)
IF '$PIECE(^(0),U,20)
IF $PIECE(^(0),U,19)["I"
SET RMPFERR("BATTERY TYPE MISSING")=""
+8 IF X["I"
IF $PIECE($GET(^RMPF(791810,RMPFX,101,RMPFY,90)),U,12)=""
SET RMPFERR("ISSUING USER MISSING")=""
+9 IF ID=""
IF X["I"
SET RMPFERR("ISSUE DATE MISSING")=""
QUIT
+10 if ID=""
QUIT
+11 IF ID<OD
SET RMPFERR("ISSUE DATE IS PRIOR TO ORDER DATE")=""
End DoDot:1
ISSE KILL OD,ID,BT,S0,RMPFY,X,RMPFO
QUIT
