RMPFEI ;DDC/KAW-ISSUE CUSTOM HEARING AIDS [ 06/16/95 3:06 PM ]
;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
RMPFSET I '$D(RMPFMENU) D MENU^RMPFUTL I '$D(RMPFMENU) W !!,$C(7),"*** A MENU SELECTION MUST BE MADE ***" Q ;;RMPFMENU must be defined
I '$D(RMPFSTAN)!'$D(RMPFDAT)!'$D(RMPFSYS) D ^RMPFUTL Q:'$D(RMPFSTAN)!'$D(RMPFDAT)!'$D(RMPFSYS)
A0 W @IOF,!,"ISSUE CUSTOM HEARING AIDS"
A1 W !!,"Select Order by Patient Name or Purchase Order Number: "
D READ G END:$D(RMPFOUT)
A11 I $D(RMPFQUT) W !!,"Enter the name of the patient or the Purchase Order Number of the order" G A1
G END:Y="",PO:Y?1"G"5N1"-".E S DIC="^DPT(",DIC(0)="EQM"
S X=Y D ^DIC G A0:Y=-1 S DFN=+Y,(X,CX,RMPFX)=0
F S RMPFX=$O(^RMPF(791810,"C",DFN,RMPFX)) Q:'RMPFX D
.D ARRAY^RMPFDT2 S Y=0
.F S Y=$O(RMPFO(Y)) Q:'Y I RMPFO(Y)=5,$P($G(^RMPF(791810,RMPFX,101,Y,90)),U,9) S CX=CX+1,X=RMPFX Q
I CX=0 D NONE,CONT^RMPFET G END:$D(RMPFOUT),A0
I CX=1 S RMPFX=X G SET
S RMPFP(5)="",(RMPFORD,RMPFTP)="P" D ^RMPFDS1
K RMPFX D SEL^RMPFDX G END:$D(RMPFOUT),A0:'$D(RMPFX)
D ARRAY^RMPFDT2 S Y=0 F S Y=$O(RMPFO(Y)) Q:'Y I RMPFO(Y)=5,$P($G(^RMPF(791810,RMPFX,101,Y,90)),U,9) Q
I 'Y D NONE,CONT^RMPFET G END:$D(RMPFOUT),A0
G SET
PO S X=Y,DIC="^RMPF(791810,",DIC(0)="EQM"
S DIC("S")="I $P(^(0),U,3)=5" D ^DIC K DIC G A0:Y=-1 S RMPFX=+Y
SET S S0=^RMPF(791810,RMPFX,0),DFN=$P(S0,U,4)
S RMPFTP="P",RMPFTYP=$P(S0,U,2)
I RMPFTYP,$D(^RMPF(791810.1,RMPFTYP,0)) S RMPFHAT=$P(^(0),U,2)
DISP D ^RMPFET7 G END:$D(RMPFOUT) D ^RMPFET2 G END:$D(RMPFOUT)
D ARRAY^RMPFDT2 S X=0 F S X=$O(^RMPF(791810,RMPFX,101,X)) Q:'X I $D(^(X,0)),$P(^(0),U,20),$P(^(0),U,19)["I" D APPROV1^RMPFEA2 Q
G END:$D(RMPFOUT),A0
END K %,%Y,DFN,DIC,DISYS,I,RMPFHAT,RMPFO,RMPFST,RMPFTYP,RMPFOUT,RMPFCX
K RMPFORD,RMPFP,RMPFS,RMPFX,%Y,%Y1,CT,RMPFQUT,RMPFTP,S0,X,Y Q
CONT F Q:$Y>21 W !
W !,"Type <RETURN> to continue." D READ Q
NONE W !!,"*** THERE ARE NO CERTIFIED LINE ITEMS TO BE ISSUED ***" 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFEI 2105 printed Oct 16, 2024@18:36:51 Page 2
RMPFEI ;DDC/KAW-ISSUE CUSTOM HEARING AIDS [ 06/16/95 3:06 PM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;;JUN 16, 1995
RMPFSET ;;RMPFMENU must be defined
IF '$DATA(RMPFMENU)
DO MENU^RMPFUTL
IF '$DATA(RMPFMENU)
WRITE !!,$CHAR(7),"*** A MENU SELECTION MUST BE MADE ***"
QUIT
+1 IF '$DATA(RMPFSTAN)!'$DATA(RMPFDAT)!'$DATA(RMPFSYS)
DO ^RMPFUTL
if '$DATA(RMPFSTAN)!'$DATA(RMPFDAT)!'$DATA(RMPFSYS)
QUIT
A0 WRITE @IOF,!,"ISSUE CUSTOM HEARING AIDS"
A1 WRITE !!,"Select Order by Patient Name or Purchase Order Number: "
+1 DO READ
if $DATA(RMPFOUT)
GOTO END
A11 IF $DATA(RMPFQUT)
WRITE !!,"Enter the name of the patient or the Purchase Order Number of the order"
GOTO A1
+1 if Y=""
GOTO END
if Y?1"G"5N1"-".E
GOTO PO
SET DIC="^DPT("
SET DIC(0)="EQM"
+2 SET X=Y
DO ^DIC
if Y=-1
GOTO A0
SET DFN=+Y
SET (X,CX,RMPFX)=0
+3 FOR
SET RMPFX=$ORDER(^RMPF(791810,"C",DFN,RMPFX))
if 'RMPFX
QUIT
Begin DoDot:1
+4 DO ARRAY^RMPFDT2
SET Y=0
+5 FOR
SET Y=$ORDER(RMPFO(Y))
if 'Y
QUIT
IF RMPFO(Y)=5
IF $PIECE($GET(^RMPF(791810,RMPFX,101,Y,90)),U,9)
SET CX=CX+1
SET X=RMPFX
QUIT
End DoDot:1
+6 IF CX=0
DO NONE
DO CONT^RMPFET
if $DATA(RMPFOUT)
GOTO END
GOTO A0
+7 IF CX=1
SET RMPFX=X
GOTO SET
+8 SET RMPFP(5)=""
SET (RMPFORD,RMPFTP)="P"
DO ^RMPFDS1
+9 KILL RMPFX
DO SEL^RMPFDX
if $DATA(RMPFOUT)
GOTO END
if '$DATA(RMPFX)
GOTO A0
+10 DO ARRAY^RMPFDT2
SET Y=0
FOR
SET Y=$ORDER(RMPFO(Y))
if 'Y
QUIT
IF RMPFO(Y)=5
IF $PIECE($GET(^RMPF(791810,RMPFX,101,Y,90)),U,9)
QUIT
+11 IF 'Y
DO NONE
DO CONT^RMPFET
if $DATA(RMPFOUT)
GOTO END
GOTO A0
+12 GOTO SET
PO SET X=Y
SET DIC="^RMPF(791810,"
SET DIC(0)="EQM"
+1 SET DIC("S")="I $P(^(0),U,3)=5"
DO ^DIC
KILL DIC
if Y=-1
GOTO A0
SET RMPFX=+Y
SET SET S0=^RMPF(791810,RMPFX,0)
SET DFN=$PIECE(S0,U,4)
+1 SET RMPFTP="P"
SET RMPFTYP=$PIECE(S0,U,2)
+2 IF RMPFTYP
IF $DATA(^RMPF(791810.1,RMPFTYP,0))
SET RMPFHAT=$PIECE(^(0),U,2)
DISP DO ^RMPFET7
if $DATA(RMPFOUT)
GOTO END
DO ^RMPFET2
if $DATA(RMPFOUT)
GOTO END
+1 DO ARRAY^RMPFDT2
SET X=0
FOR
SET X=$ORDER(^RMPF(791810,RMPFX,101,X))
if 'X
QUIT
IF $DATA(^(X,0))
IF $PIECE(^(0),U,20)
IF $PIECE(^(0),U,19)["I"
DO APPROV1^RMPFEA2
QUIT
+2 if $DATA(RMPFOUT)
GOTO END
GOTO A0
END KILL %,%Y,DFN,DIC,DISYS,I,RMPFHAT,RMPFO,RMPFST,RMPFTYP,RMPFOUT,RMPFCX
+1 KILL RMPFORD,RMPFP,RMPFS,RMPFX,%Y,%Y1,CT,RMPFQUT,RMPFTP,S0,X,Y
QUIT
CONT FOR
if $Y>21
QUIT
WRITE !
+1 WRITE !,"Type <RETURN> to continue."
DO READ
QUIT
NONE WRITE !!,"*** THERE ARE NO CERTIFIED LINE ITEMS TO BE ISSUED ***"
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
