- 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 Feb 19, 2025@00:02:45 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
