- RMPFEA ;DDC/KAW-APPROVE/DISAPPROVE ORDERS; [ 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)
- W @IOF,!,"APPROVE/DISAPPROVE ORDERS" D APRV G END:'AP
- WRITE W !!,"APPROVAL",?13,"will place an order in the open transmission batch",!?13,"with the status APPROVED"
- W !!,"DISAPPROVAL",?13,"of an order will terminate that order with a status",!?13,"of DISAPPROVED."
- D CONT G END:$D(RMPFOUT),RMPFSET:$D(RMPFQUT),RMPFSET:Y'=""
- START S RMPFORD="S",RMPFTP="B" K RMPFP S RMPFP(2)="" D ^RMPFDS1 K RMPFP
- D SEL^RMPFEA1 G END:$D(RMPFOUT)
- I RMPFM="M" D MULTI^RMPFEA1 G END:$D(RMPFOUT),START
- G END:'$D(RMPFX)
- S DFN=$P(^RMPF(791810,RMPFX,0),U,4) I DFN D PAT^RMPFUTL
- S S0=^RMPF(791810,RMPFX,0),RMPFTYP=$P(S0,U,2) I 'RMPFTYP D MSG G END
- I '$D(^RMPF(791810.1,RMPFTYP,0)) D MSG G END
- S TP=$P(^RMPF(791810.1,RMPFTYP,0),U,3)
- ST1 D ^RMPFDT1 S RMPFHAT="",X=$P(^RMPF(791810,RMPFX,0),U,2)
- I X,$D(^RMPF(791810.1,X,0)) S RMPFHAT=$P(^(0),U,2)
- APP W !!,"Enter <A>pprove, <D>isapprove" S FX="AaDd"
- I RMPFHAT="C" W ", <H>istory" S FX=FX_"Hh"
- W " or <^> to exit: A// " D READ G END:$D(RMPFOUT)
- APP1 I $D(RMPFQUT) W !!,"Enter an <A> if you wish to approve this order,",!?7,"a <D> if you wish to disapprove this order" W:FX["H" !?6,"an <H> to view the history of the order" W !?6,"an <^> to exit." G APP
- S:Y="" Y="A" S Y=$E(Y,1) I FX'[Y S RMPFQUT="" G APP1
- I "Hh"[Y D ^RMPFDT7 G END:$D(RMPFOUT),ST1
- I "Dd"[Y D DIS G END:$D(RMPFOUT),START
- S X="NOW",%DT="T" D ^%DT D SET^RMPFEA2 G START
- END K RMPFNAM,RMPFSSN,RMPFDOB,RMPFORD,RMPFTP,RMPFP,RMPFM,RMPFS,S0,DFN
- K Y,L,CM,FX,RMPFO,RMPFTYP,TP,RMPFOUT,RMPFQUT,T,J,DISYS,RMPFDOD,SS
- K SP,%,%Y,%DT,RMPFCX,D,D0,DA,DIC,DIE,DI,DQ,DR,FY,PR,PJ,I,X,AP Q
- DIS ;; input: RMPFX
- ;;output: None
- W !!,"Reason for Disapproval: " D READ G END:$D(RMPFOUT)
- DIS1 I $D(RMPFQUT) W !!,"Enter the reason for disapproving this order in 3 to 30 characters." G DIS
- I $L(Y)<3!$L(Y)>30 S RMPFQUT="" G DIS
- S RMPFDR=Y,X="NOW",%DT="T" D ^%DT S TD=Y
- S DA=RMPFX,DIE="^RMPF(791810,",DR=".03////7;.06////"_TD_";.1////"_DUZ_";.11////"_DT_";10.02////"_RMPFDR D ^DIE
- S DIE="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DR=".17////"_TD_";.18////7"
- S DA=0 F S DA=$O(^RMPF(791810,RMPFX,101,DA)) Q:'DA D ^DIE
- K DA,DIE,DR,Y,RMPFDR,TD Q
- APRV S X=$P(RMPFSYS,U,7),AP=0 S:X="" X="S"
- I X="N" W $C(7),!!,"*** APPROVAL PROCESS OCCURS AUTOMATICALLY WHEN ORDER IS PLACED ***" D CONT G APRVE
- I RMPFMENU=10,X="A" S AP=1 G APRVE
- I $D(^XUSEC("RMPF SUPERVISOR",DUZ)) S AP=1 G APRVE
- I X="A",$D(^RMPF(791813,RMPFSTAN,101,DUZ,0)),$P(^(0),U,3) S AP=1 G APRVE
- D MSG,CONT
- APRVE 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
- MSG W $C(7),!!,"*** YOU HAVE NOT BEEN DESIGNATED AS ",$S($P(RMPFSYS,U,7)="A":"AN AUDIOLOGIST OR SUPERVISOR",1:"A SUPERVISOR")," ***" Q
- CONT F I=1:1 Q:$Y>20 W !
- W !!,"Enter <RETURN> to continue." D READ Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFEA 3196 printed Jan 18, 2025@03:37:10 Page 2
- RMPFEA ;DDC/KAW-APPROVE/DISAPPROVE ORDERS; [ 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
- +2 WRITE @IOF,!,"APPROVE/DISAPPROVE ORDERS"
- DO APRV
- if 'AP
- GOTO END
- WRITE WRITE !!,"APPROVAL",?13,"will place an order in the open transmission batch",!?13,"with the status APPROVED"
- +1 WRITE !!,"DISAPPROVAL",?13,"of an order will terminate that order with a status",!?13,"of DISAPPROVED."
- +2 DO CONT
- if $DATA(RMPFOUT)
- GOTO END
- if $DATA(RMPFQUT)
- GOTO RMPFSET
- if Y'=""
- GOTO RMPFSET
- START SET RMPFORD="S"
- SET RMPFTP="B"
- KILL RMPFP
- SET RMPFP(2)=""
- DO ^RMPFDS1
- KILL RMPFP
- +1 DO SEL^RMPFEA1
- if $DATA(RMPFOUT)
- GOTO END
- +2 IF RMPFM="M"
- DO MULTI^RMPFEA1
- if $DATA(RMPFOUT)
- GOTO END
- GOTO START
- +3 if '$DATA(RMPFX)
- GOTO END
- +4 SET DFN=$PIECE(^RMPF(791810,RMPFX,0),U,4)
- IF DFN
- DO PAT^RMPFUTL
- +5 SET S0=^RMPF(791810,RMPFX,0)
- SET RMPFTYP=$PIECE(S0,U,2)
- IF 'RMPFTYP
- DO MSG
- GOTO END
- +6 IF '$DATA(^RMPF(791810.1,RMPFTYP,0))
- DO MSG
- GOTO END
- +7 SET TP=$PIECE(^RMPF(791810.1,RMPFTYP,0),U,3)
- ST1 DO ^RMPFDT1
- SET RMPFHAT=""
- SET X=$PIECE(^RMPF(791810,RMPFX,0),U,2)
- +1 IF X
- IF $DATA(^RMPF(791810.1,X,0))
- SET RMPFHAT=$PIECE(^(0),U,2)
- APP WRITE !!,"Enter <A>pprove, <D>isapprove"
- SET FX="AaDd"
- +1 IF RMPFHAT="C"
- WRITE ", <H>istory"
- SET FX=FX_"Hh"
- +2 WRITE " or <^> to exit: A// "
- DO READ
- if $DATA(RMPFOUT)
- GOTO END
- APP1 IF $DATA(RMPFQUT)
- WRITE !!,"Enter an <A> if you wish to approve this order,",!?7,"a <D> if you wish to disapprove this order"
- if FX["H"
- WRITE !?6,"an <H> to view the history of the order"
- WRITE !?6,"an <^> to exit."
- GOTO APP
- +1 if Y=""
- SET Y="A"
- SET Y=$EXTRACT(Y,1)
- IF FX'[Y
- SET RMPFQUT=""
- GOTO APP1
- +2 IF "Hh"[Y
- DO ^RMPFDT7
- if $DATA(RMPFOUT)
- GOTO END
- GOTO ST1
- +3 IF "Dd"[Y
- DO DIS
- if $DATA(RMPFOUT)
- GOTO END
- GOTO START
- +4 SET X="NOW"
- SET %DT="T"
- DO ^%DT
- DO SET^RMPFEA2
- GOTO START
- END KILL RMPFNAM,RMPFSSN,RMPFDOB,RMPFORD,RMPFTP,RMPFP,RMPFM,RMPFS,S0,DFN
- +1 KILL Y,L,CM,FX,RMPFO,RMPFTYP,TP,RMPFOUT,RMPFQUT,T,J,DISYS,RMPFDOD,SS
- +2 KILL SP,%,%Y,%DT,RMPFCX,D,D0,DA,DIC,DIE,DI,DQ,DR,FY,PR,PJ,I,X,AP
- QUIT
- DIS ;; input: RMPFX
- +1 ;;output: None
- +2 WRITE !!,"Reason for Disapproval: "
- DO READ
- if $DATA(RMPFOUT)
- GOTO END
- DIS1 IF $DATA(RMPFQUT)
- WRITE !!,"Enter the reason for disapproving this order in 3 to 30 characters."
- GOTO DIS
- +1 IF $LENGTH(Y)<3!$LENGTH(Y)>30
- SET RMPFQUT=""
- GOTO DIS
- +2 SET RMPFDR=Y
- SET X="NOW"
- SET %DT="T"
- DO ^%DT
- SET TD=Y
- +3 SET DA=RMPFX
- SET DIE="^RMPF(791810,"
- SET DR=".03////7;.06////"_TD_";.1////"_DUZ_";.11////"_DT_";10.02////"_RMPFDR
- DO ^DIE
- +4 SET DIE="^RMPF(791810,"_RMPFX_",101,"
- SET DA(1)=RMPFX
- SET DR=".17////"_TD_";.18////7"
- +5 SET DA=0
- FOR
- SET DA=$ORDER(^RMPF(791810,RMPFX,101,DA))
- if 'DA
- QUIT
- DO ^DIE
- +6 KILL DA,DIE,DR,Y,RMPFDR,TD
- QUIT
- APRV SET X=$PIECE(RMPFSYS,U,7)
- SET AP=0
- if X=""
- SET X="S"
- +1 IF X="N"
- WRITE $CHAR(7),!!,"*** APPROVAL PROCESS OCCURS AUTOMATICALLY WHEN ORDER IS PLACED ***"
- DO CONT
- GOTO APRVE
- +2 IF RMPFMENU=10
- IF X="A"
- SET AP=1
- GOTO APRVE
- +3 IF $DATA(^XUSEC("RMPF SUPERVISOR",DUZ))
- SET AP=1
- GOTO APRVE
- +4 IF X="A"
- IF $DATA(^RMPF(791813,RMPFSTAN,101,DUZ,0))
- IF $PIECE(^(0),U,3)
- SET AP=1
- GOTO APRVE
- +5 DO MSG
- DO CONT
- APRVE 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
- MSG WRITE $CHAR(7),!!,"*** YOU HAVE NOT BEEN DESIGNATED AS ",$SELECT($PIECE(RMPFSYS,U,7)="A":"AN AUDIOLOGIST OR SUPERVISOR",1:"A SUPERVISOR")," ***"
- QUIT
- CONT FOR I=1:1
- if $Y>20
- QUIT
- WRITE !
- +1 WRITE !!,"Enter <RETURN> to continue."
- DO READ
- QUIT