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