RMPFET0 ;DDC/KAW-SELECTION ORDER ACTIONS [ 11/06/97 4:53 PM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;**20**;MAY 30, 1995
SELOPT ;; input: RMPFX,RMPFST,RMPFHAT,RMPFTYP
;;output: RMPFSEL
F I=1:1 Q:$Y>20 W !
SELEN W !,"Enter" S FX="" K RMPFSEL Q:'RMPFST
S SU=$P(^RMPF(791810.2,RMPFST,0),U,2)
F I="I","P","E","F","D" I SU=I,RMPFTYP'=5 W " Number, <E>dit, <D>elete" S FX=FX_"EeDd" Q
SELOPT0 I RMPFTYP=5!(RMPFTYP=8) D ARRAY^RMPFDT2 D K RMPFO
.F I="I","P","E","F","D","S","B" I SU=I D
..I $P(^RMPF(791810,RMPFX,0),"^",9)>3010630 D
...W:FX'="" "," W " <A>djust" S FX=FX_"Aa"
..S (X,FL)=0
..F S X=$O(RMPFO(X)) Q:'X I $D(^RMPF(791810,RMPFX,101,X,90)),$P(^(90),U,9) S FL=1 Q
..I FL,RMPFTYP'=8 W:FX'="" "," W " <I>ssue" S FX=FX_"Ii"
.S X=0
.F S X=$O(RMPFO(X)) Q:'X S S0=^RMPF(791810,RMPFX,101,X,0),Y=$P(S0,U,18) I Y,$D(^RMPF(791810.2,Y,0)) S Y=$P(^(0),U,2) I "SEDF"[Y D CERT Q:FX["Rr"
.I SU="C",FX'["A" S X=DT,Z=60 D PASTWKDY D
..S X=0
..F S X=$O(RMPFO(X)) Q:'X I $P(^(0),U,19)'="C" W:FX'="" "," W " <A>djust" S FX=FX_"Aa" Q
I $O(^RMPF(791810,RMPFX,201,0)) W:FX'="" "," W " <M>essages" S FX=FX_"Mm"
I $O(^RMPF(791810,RMPFX,301,0)) W:FX'="" "," W " A<U>thorized Aids" S FX=FX_"Uu"
D CAN I CN W:FX'="" "," W " <C>ancel" S FX=FX_"Cc"
I "CIX"[RMPFHAT W:FX'="" "," W:$X>69 ! W " <H>istory" S FX=FX_"Hh"
I RMPFTP="P" W:FX'="" "," W:$X>69 ! W " E<X>tended" S FX=FX_"Xx"
W:$X>69 ! W:FX'="" " or" W:$X>69 ! W " <RETURN>: "
D READ G SELOPTE:$D(RMPFOUT) K RMPFF,CN
SELOPT1 I $D(RMPFQUT) D MSG K RMPFSEL G SELOPTE
I Y="" D ^RMPFEA2:'$D(RMPFERR) G SELOPTE:$D(RMPFOUT) K RMPFX G SELOPTE
I Y?1N.E,FX["Ee" S RMPFSEL=Y G NUM
S RMPFSEL=$E(Y,1)
I FX'[RMPFSEL S RMPFQUT="" G SELOPT1
I "Ee"[RMPFSEL S RMPFSEL="E" G SELOPTE
I "Hh"[RMPFSEL D ^RMPFDT7 G SELOPTE
I "Mm"[RMPFSEL D ^RMPFDT4 G SELOPTE
I "Dd"[RMPFSEL D DELETE^RMPFET1 G SELOPTE
I "Ii"[RMPFSEL D ^RMPFET7 G SELOPTE:$D(RMPFOUT) D ^RMPFET2 G SELOPTE
I "Rr"[RMPFSEL N RMPFSEL D DISP^RMPFET84 G SELOPTE
I "Aa"[RMPFSEL D ^RMPFET8 G SELOPTE:$D(RMPFOUT) D ^RMPFET2 G SELOPTE
I "Uu"[RMPFSEL D ^RMPFDT8 G SELOPTE
I "Cc"[RMPFSEL D ^RMPFET82 G SELOPTE
I "Xx"[RMPFSEL D ^RMPFDT9 G SELOPTE
NUM K RMPFQUT
F I=1:1 S Z=$P(Y,",",I) Q:Z="" D G SELOPT1:$D(RMPFQUT)
.I Z?1N.N,Z>0,Z<11 S RMPFSL(Z)="" Q
.S RMPFQUT="" Q
I $D(RMPFSL) D SUB^RMPFET5
SELOPTE K I,FX,Y,X,Z,SU,X1,X2,%Y,S0,A,FL
END K ID Q
CERT S A=$G(^RMPF(791810,RMPFX,101,X,90))
I '$P(A,U,11),$P(S0,U,20) Q
I '$P(A,U,9),"EDSF"[Y G CERT1
I $P(A,U,9),"EDF"[Y G CERT1
I $P(A,U,9),$P(S0,U,19)["R",$P(S0,U,20) G CERT1
E Q
CERT1 W:FX'="" "," W:$P(A,U,9) " Re-" W:'$P(A,U,9) " " W "Ce<R>tify" S FX=FX_"Rr" Q
CAN ;;Calculate if CANCEL ALLOWED
;; input: RMPFHAT,RMPFX
;;output: CN
D ARRAY^RMPFDT2
S CN=0 G CANE:"ICXZBDJQW"'[RMPFHAT
I "ZBDJQW"[RMPFHAT D G CANE
.S X=0 F S X=$O(RMPFO(X)) Q:'X I RMPFO(X)=18!($P(^RMPF(791810,RMPFX,101,X,0),U,15)="C") S CN=1 Q
S XX=0 F S XX=$O(RMPFO(XX)) Q:'XX D Q:CN
.I RMPFO(XX)=5!(RMPFO(XX)=17) S CN=1 Q
.I RMPFHAT="I",RMPFO(XX)=8 S X=DT,Z=60 D PASTWKDY S ID=$P(^RMPF(791810,RMPFX,101,XX,0),U,8) I ID>Y S CN=1
CANE K X,XX,RMPFO Q
READ K RMPFOUT,RMPFQUT
R Y:DTIME I '$T W $C(7) R Y:5 G READ:Y="." S:'$T Y=U
I Y?1"^".E S (RMPFOUT,Y)="" Q
S:Y?1"?".E (RMPFQUT,Y)=""
Q
PASTWKDY Q:X'?7N
;returns a date Z workdays into the past
N BD,DW,WK,%H S WK=0 S:'$G(Z) Z=5
W1 S X1=X,X2=-1 D C^%DTC,H^%DTC
I %Y,%Y<6,'$D(^HOLIDAY(X)) S WK=WK+1
I WK>Z S Y=X Q
G W1
MSG W !!,"Enter " S CT=0
F I=1:2 S X=$E(FX,I) Q:X="" W:CT ! W ?6,$P($T(@X),";;",2) S CT=CT+1
F I="I","P","E","D" I SU=I W !?6,"field numbers separated by commas to edit only those fields" Q
W:FX'="" ! W ?6,"<RETURN> to continue.",!
W !!!,"Type <RETURN> to continue: " D READ I '$D(RMPFOUT) S RMPFQUT=""
K CT Q
E ;;<E> to edit all fields of the order
D ;;<D> to delete the entire order
M ;;<M> to view all messages for the order
H ;;<H> to view the order history
I ;;<I> to enter the issue date
A ;;<A> to make an adjustment
C ;;<C> to cancel the order
R ;;<R> to certify that the order was received
U ;;<U> to view a list of authorized hearing aids
X ;;<X> to view the extended information for this order
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFET0 4215 printed Dec 13, 2024@02:36:14 Page 2
RMPFET0 ;DDC/KAW-SELECTION ORDER ACTIONS [ 11/06/97 4:53 PM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**20**;MAY 30, 1995
SELOPT ;; input: RMPFX,RMPFST,RMPFHAT,RMPFTYP
+1 ;;output: RMPFSEL
+2 FOR I=1:1
if $Y>20
QUIT
WRITE !
SELEN WRITE !,"Enter"
SET FX=""
KILL RMPFSEL
if 'RMPFST
QUIT
+1 SET SU=$PIECE(^RMPF(791810.2,RMPFST,0),U,2)
+2 FOR I="I","P","E","F","D"
IF SU=I
IF RMPFTYP'=5
WRITE " Number, <E>dit, <D>elete"
SET FX=FX_"EeDd"
QUIT
SELOPT0 IF RMPFTYP=5!(RMPFTYP=8)
DO ARRAY^RMPFDT2
Begin DoDot:1
+1 FOR I="I","P","E","F","D","S","B"
IF SU=I
Begin DoDot:2
+2 IF $PIECE(^RMPF(791810,RMPFX,0),"^",9)>3010630
Begin DoDot:3
+3 if FX'=""
WRITE ","
WRITE " <A>djust"
SET FX=FX_"Aa"
End DoDot:3
+4 SET (X,FL)=0
+5 FOR
SET X=$ORDER(RMPFO(X))
if 'X
QUIT
IF $DATA(^RMPF(791810,RMPFX,101,X,90))
IF $PIECE(^(90),U,9)
SET FL=1
QUIT
+6 IF FL
IF RMPFTYP'=8
if FX'=""
WRITE ","
WRITE " <I>ssue"
SET FX=FX_"Ii"
End DoDot:2
+7 SET X=0
+8 FOR
SET X=$ORDER(RMPFO(X))
if 'X
QUIT
SET S0=^RMPF(791810,RMPFX,101,X,0)
SET Y=$PIECE(S0,U,18)
IF Y
IF $DATA(^RMPF(791810.2,Y,0))
SET Y=$PIECE(^(0),U,2)
IF "SEDF"[Y
DO CERT
if FX["Rr"
QUIT
+9 IF SU="C"
IF FX'["A"
SET X=DT
SET Z=60
DO PASTWKDY
Begin DoDot:2
+10 SET X=0
+11 FOR
SET X=$ORDER(RMPFO(X))
if 'X
QUIT
IF $PIECE(^(0),U,19)'="C"
if FX'=""
WRITE ","
WRITE " <A>djust"
SET FX=FX_"Aa"
QUIT
End DoDot:2
End DoDot:1
KILL RMPFO
+12 IF $ORDER(^RMPF(791810,RMPFX,201,0))
if FX'=""
WRITE ","
WRITE " <M>essages"
SET FX=FX_"Mm"
+13 IF $ORDER(^RMPF(791810,RMPFX,301,0))
if FX'=""
WRITE ","
WRITE " A<U>thorized Aids"
SET FX=FX_"Uu"
+14 DO CAN
IF CN
if FX'=""
WRITE ","
WRITE " <C>ancel"
SET FX=FX_"Cc"
+15 IF "CIX"[RMPFHAT
if FX'=""
WRITE ","
if $X>69
WRITE !
WRITE " <H>istory"
SET FX=FX_"Hh"
+16 IF RMPFTP="P"
if FX'=""
WRITE ","
if $X>69
WRITE !
WRITE " E<X>tended"
SET FX=FX_"Xx"
+17 if $X>69
WRITE !
if FX'=""
WRITE " or"
if $X>69
WRITE !
WRITE " <RETURN>: "
+18 DO READ
if $DATA(RMPFOUT)
GOTO SELOPTE
KILL RMPFF,CN
SELOPT1 IF $DATA(RMPFQUT)
DO MSG
KILL RMPFSEL
GOTO SELOPTE
+1 IF Y=""
if '$DATA(RMPFERR)
DO ^RMPFEA2
if $DATA(RMPFOUT)
GOTO SELOPTE
KILL RMPFX
GOTO SELOPTE
+2 IF Y?1N.E
IF FX["Ee"
SET RMPFSEL=Y
GOTO NUM
+3 SET RMPFSEL=$EXTRACT(Y,1)
+4 IF FX'[RMPFSEL
SET RMPFQUT=""
GOTO SELOPT1
+5 IF "Ee"[RMPFSEL
SET RMPFSEL="E"
GOTO SELOPTE
+6 IF "Hh"[RMPFSEL
DO ^RMPFDT7
GOTO SELOPTE
+7 IF "Mm"[RMPFSEL
DO ^RMPFDT4
GOTO SELOPTE
+8 IF "Dd"[RMPFSEL
DO DELETE^RMPFET1
GOTO SELOPTE
+9 IF "Ii"[RMPFSEL
DO ^RMPFET7
if $DATA(RMPFOUT)
GOTO SELOPTE
DO ^RMPFET2
GOTO SELOPTE
+10 IF "Rr"[RMPFSEL
NEW RMPFSEL
DO DISP^RMPFET84
GOTO SELOPTE
+11 IF "Aa"[RMPFSEL
DO ^RMPFET8
if $DATA(RMPFOUT)
GOTO SELOPTE
DO ^RMPFET2
GOTO SELOPTE
+12 IF "Uu"[RMPFSEL
DO ^RMPFDT8
GOTO SELOPTE
+13 IF "Cc"[RMPFSEL
DO ^RMPFET82
GOTO SELOPTE
+14 IF "Xx"[RMPFSEL
DO ^RMPFDT9
GOTO SELOPTE
NUM KILL RMPFQUT
+1 FOR I=1:1
SET Z=$PIECE(Y,",",I)
if Z=""
QUIT
Begin DoDot:1
+2 IF Z?1N.N
IF Z>0
IF Z<11
SET RMPFSL(Z)=""
QUIT
+3 SET RMPFQUT=""
QUIT
End DoDot:1
if $DATA(RMPFQUT)
GOTO SELOPT1
+4 IF $DATA(RMPFSL)
DO SUB^RMPFET5
SELOPTE KILL I,FX,Y,X,Z,SU,X1,X2,%Y,S0,A,FL
END KILL ID
QUIT
CERT SET A=$GET(^RMPF(791810,RMPFX,101,X,90))
+1 IF '$PIECE(A,U,11)
IF $PIECE(S0,U,20)
QUIT
+2 IF '$PIECE(A,U,9)
IF "EDSF"[Y
GOTO CERT1
+3 IF $PIECE(A,U,9)
IF "EDF"[Y
GOTO CERT1
+4 IF $PIECE(A,U,9)
IF $PIECE(S0,U,19)["R"
IF $PIECE(S0,U,20)
GOTO CERT1
+5 IF '$TEST
QUIT
CERT1 if FX'=""
WRITE ","
if $PIECE(A,U,9)
WRITE " Re-"
if '$PIECE(A,U,9)
WRITE " "
WRITE "Ce<R>tify"
SET FX=FX_"Rr"
QUIT
CAN ;;Calculate if CANCEL ALLOWED
+1 ;; input: RMPFHAT,RMPFX
+2 ;;output: CN
+3 DO ARRAY^RMPFDT2
+4 SET CN=0
if "ICXZBDJQW"'[RMPFHAT
GOTO CANE
+5 IF "ZBDJQW"[RMPFHAT
Begin DoDot:1
+6 SET X=0
FOR
SET X=$ORDER(RMPFO(X))
if 'X
QUIT
IF RMPFO(X)=18!($PIECE(^RMPF(791810,RMPFX,101,X,0),U,15)="C")
SET CN=1
QUIT
End DoDot:1
GOTO CANE
+7 SET XX=0
FOR
SET XX=$ORDER(RMPFO(XX))
if 'XX
QUIT
Begin DoDot:1
+8 IF RMPFO(XX)=5!(RMPFO(XX)=17)
SET CN=1
QUIT
+9 IF RMPFHAT="I"
IF RMPFO(XX)=8
SET X=DT
SET Z=60
DO PASTWKDY
SET ID=$PIECE(^RMPF(791810,RMPFX,101,XX,0),U,8)
IF ID>Y
SET CN=1
End DoDot:1
if CN
QUIT
CANE KILL X,XX,RMPFO
QUIT
READ KILL RMPFOUT,RMPFQUT
+1 READ Y:DTIME
IF '$TEST
WRITE $CHAR(7)
READ Y:5
if Y="."
GOTO READ
if '$TEST
SET Y=U
+2 IF Y?1"^".E
SET (RMPFOUT,Y)=""
QUIT
+3 if Y?1"?".E
SET (RMPFQUT,Y)=""
+4 QUIT
PASTWKDY if X'?7N
QUIT
+1 ;returns a date Z workdays into the past
+2 NEW BD,DW,WK,%H
SET WK=0
if '$GET(Z)
SET Z=5
W1 SET X1=X
SET X2=-1
DO C^%DTC
DO H^%DTC
+1 IF %Y
IF %Y<6
IF '$DATA(^HOLIDAY(X))
SET WK=WK+1
+2 IF WK>Z
SET Y=X
QUIT
+3 GOTO W1
MSG WRITE !!,"Enter "
SET CT=0
+1 FOR I=1:2
SET X=$EXTRACT(FX,I)
if X=""
QUIT
if CT
WRITE !
WRITE ?6,$PIECE($TEXT(@X),";;",2)
SET CT=CT+1
+2 FOR I="I","P","E","D"
IF SU=I
WRITE !?6,"field numbers separated by commas to edit only those fields"
QUIT
+3 if FX'=""
WRITE !
WRITE ?6,"<RETURN> to continue.",!
+4 WRITE !!!,"Type <RETURN> to continue: "
DO READ
IF '$DATA(RMPFOUT)
SET RMPFQUT=""
+5 KILL CT
QUIT
E ;;<E> to edit all fields of the order
D ;;<D> to delete the entire order
M ;;<M> to view all messages for the order
H ;;<H> to view the order history
I ;;<I> to enter the issue date
A ;;<A> to make an adjustment
C ;;<C> to cancel the order
R ;;<R> to certify that the order was received
U ;;<U> to view a list of authorized hearing aids
X ;;<X> to view the extended information for this order
