- RMPFER ;DDC/KAW-REMOVE ORDER FROM A BATCH; [ 04/04/97 8:35 AM ]
- ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**4**;MAY 30, 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,!,"REMOVE ORDER FROM A BATCH"
- I '$D(^RMPF(791812,"C",1)) W $C(7),!!,"*** NO BATCHES CURRENTLY OPEN ***" G END
- W !!,"Currently Open Batch:",! F I=1:1:21 W "-"
- A0 S (RMPFBT,CT)=0,RM=$O(^RMPF(791810.5,"C",RMPFMENU,0))
- A1 S RMPFBT=$O(^RMPF(791812,"C",1,RMPFBT))
- G A2:'RMPFBT,A1:'$D(^RMPF(791812,RMPFBT,0)) S S0=^(0)
- G A1:$P(S0,U,2)'=1 S Y=$P(S0,U,1) D DD^%DT
- G A1:$P(S0,U,8)'=RMPFSTAP,A1:$P(S0,U,9)'=RM
- S D=Y,N=$P(S0,U,4) W !!,"Date/Time Opened: ",D
- W !?1,"Number in Batch: ",N S CT=CT+1,RMPFBTH=RMPFBT G A1
- A2 I CT=0 W !!,"*** NO OPEN BATCH ***" G END
- I CT=1 S RMPFBT=RMPFBTH G END:'RMPFBT,END:'$D(^RMPF(791812,RMPFBT,0)),A4
- S %DT("A")="Select Date/Time of Batch to Edit: " W !
- S %DT="AET" D ^%DT G END:Y=-1 S X=$O(^RMPF(791812,"B",Y,0))
- I X,$D(^RMPF(791812,X,0)),$P(^(0),U,2)=1 G A3
- W $C(7) G A0
- A3 S RMPFBT=X K RMPFBJ
- A4 W !!,"Display batch entries? YES// " D READ G END:$D(RMPFOUT)
- A41 I $D(RMPFQUT) W !!,"Type <Y> or <RETURN> to display entries in the batch or <N> to continue." G A4
- S:Y="" Y="Y" I "YyNn"'[Y S RMPFQUT="" G A41
- G END:"Nn"[Y
- A42 D ^RMPFDB1
- D DELETE G END:$D(RMPFOUT)!'$D(RMPFBJ),RMPFSET
- END K RMPFB,RMPFBJ,N,D,RMPFBT,POP,I,CT,X,Y,%,%DT,RM 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
- DELETE ;;input: RMPFB
- ;;output: None
- K RMPFBJ
- W !!,"Enter Order Numbers Separated by Commas: "
- D READ G DELETEE:$D(RMPFOUT)
- DELE I $D(RMPFQUT) W !!,"Select the number(s) to the left of the orders you wish to delete.",!,"Separate numbers with commas." G DELETE
- G DELETEE:Y=""
- F I=1:1 S X=$P(Y,",",I) Q:X="" I '$D(RMPFB(X)) S RMPFQUT="" Q
- G DELE:$D(RMPFQUT) S SG=Y W !!
- F I=1:1 S RX=$P(SG,",",I) Q:RX="" I $D(RMPFB(RX)) S RMPFBJ=RMPFB(RX) I $D(^RMPF(791812,RMPFBT,101,RMPFBJ,0)) S RMPFX=$P(^(0),U,1) D DEL
- K X,Y,I,SG,RX Q
- DEL I $D(RMPFX),RMPFX,$D(^RMPF(791810,RMPFX,0)) G DEL0
- W !!?25,$C(7),"*** ORDER DOES NOT EXIST *** " G DELETEE
- DEL0 W !!,"Order: " S Y=$P(^RMPF(791810,RMPFX,0),U,1) D DD^%DT W Y S X=$P(^RMPF(791810,RMPFX,0),U,2) I X,$D(^RMPF(791810.1,X,0)) W ?$X+5,$P(^(0),U,1)
- W !!,"Are you sure you want to delete this order from the batch? NO// " D READ
- G DELETEE:$D(RMPFOUT)
- DEL1 I $D(RMPFQUT) W !!,"Enter <N> or <RETURN> to continue or <Y> to delete the order." G DEL0
- S:Y="" Y="N" S Y=$E(Y,1) I "yYnN"'[Y S RMPFQUT="" G DEL1
- G DELETEE:"Nn"[Y
- DEL2 W !!,"Enter reason for deletion: " D READ
- G DELETEE:$D(RMPFOUT)
- DEL3 I $D(RMPFQUT) W !!,"You must enter a reason for the deletion (3 to 30 characters)." G DEL2
- I $L(Y)<3!$L(Y)>30 S RMPFQUT="" G DEL3
- S RMPFDLR=Y
- S X="NOW",%DT="TR" D ^%DT S RMPFDTD=Y
- S DIE="^RMPF(791812,"_RMPFBT_",101,",DA(1)=RMPFBT,DA=RMPFBJ
- S DR=".02////"_DUZ_";.03////"_RMPFDTD_";.04////"_RMPFDLR D ^DIE
- L ^RMPF(791812,RMPFBT,0) S X=$P(^RMPF(791812,RMPFBT,0),U,4) S:X X=X-1 S $P(^(0),U,4)=X
- I X=0 S Y=$P(^RMPF(791812,RMPFBT,0),U,2) K:Y ^RMPF(791812,"C",Y,RMPFBT) S Y=$P(^RMPF(791812,RMPFBT,0),U,1) K ^RMPF(791812,RMPFBT),^RMPF(791812,"B",Y,RMPFBT)
- L
- S DIE="^RMPF(791810,",DA=RMPFX,DR=".03///DISAPPROVED;.06////"_RMPFDTD_";.1////"_DUZ_";.11////"_RMPFDTD_";10.02////"_RMPFDLR D ^DIE
- S DIE="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX
- S DR=".17////"_RMPFDTD_";.18///DISAPPROVED;.2////1",DA=0
- D ARRAY^RMPFDT2 F S DA=$O(RMPFO(DA)) Q:'DA D ^DIE
- W !!?20,"*** ORDER DELETED FROM BATCH ***" H 2
- DELETEE K RMPFX,RMPFDLR,RMPFDTD,DI,D0,DQ,%DT,DA,DC,DIE,DIC,DA,DR,D,X,Y Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFER 3851 printed Feb 19, 2025@00:02:42 Page 2
- RMPFER ;DDC/KAW-REMOVE ORDER FROM A BATCH; [ 04/04/97 8:35 AM ]
- +1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**4**;MAY 30, 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,!,"REMOVE ORDER FROM A BATCH"
- +3 IF '$DATA(^RMPF(791812,"C",1))
- WRITE $CHAR(7),!!,"*** NO BATCHES CURRENTLY OPEN ***"
- GOTO END
- +4 WRITE !!,"Currently Open Batch:",!
- FOR I=1:1:21
- WRITE "-"
- A0 SET (RMPFBT,CT)=0
- SET RM=$ORDER(^RMPF(791810.5,"C",RMPFMENU,0))
- A1 SET RMPFBT=$ORDER(^RMPF(791812,"C",1,RMPFBT))
- +1 if 'RMPFBT
- GOTO A2
- if '$DATA(^RMPF(791812,RMPFBT,0))
- GOTO A1
- SET S0=^(0)
- +2 if $PIECE(S0,U,2)'=1
- GOTO A1
- SET Y=$PIECE(S0,U,1)
- DO DD^%DT
- +3 if $PIECE(S0,U,8)'=RMPFSTAP
- GOTO A1
- if $PIECE(S0,U,9)'=RM
- GOTO A1
- +4 SET D=Y
- SET N=$PIECE(S0,U,4)
- WRITE !!,"Date/Time Opened: ",D
- +5 WRITE !?1,"Number in Batch: ",N
- SET CT=CT+1
- SET RMPFBTH=RMPFBT
- GOTO A1
- A2 IF CT=0
- WRITE !!,"*** NO OPEN BATCH ***"
- GOTO END
- +1 IF CT=1
- SET RMPFBT=RMPFBTH
- if 'RMPFBT
- GOTO END
- if '$DATA(^RMPF(791812,RMPFBT,0))
- GOTO END
- GOTO A4
- +2 SET %DT("A")="Select Date/Time of Batch to Edit: "
- WRITE !
- +3 SET %DT="AET"
- DO ^%DT
- if Y=-1
- GOTO END
- SET X=$ORDER(^RMPF(791812,"B",Y,0))
- +4 IF X
- IF $DATA(^RMPF(791812,X,0))
- IF $PIECE(^(0),U,2)=1
- GOTO A3
- +5 WRITE $CHAR(7)
- GOTO A0
- A3 SET RMPFBT=X
- KILL RMPFBJ
- A4 WRITE !!,"Display batch entries? YES// "
- DO READ
- if $DATA(RMPFOUT)
- GOTO END
- A41 IF $DATA(RMPFQUT)
- WRITE !!,"Type <Y> or <RETURN> to display entries in the batch or <N> to continue."
- GOTO A4
- +1 if Y=""
- SET Y="Y"
- IF "YyNn"'[Y
- SET RMPFQUT=""
- GOTO A41
- +2 if "Nn"[Y
- GOTO END
- A42 DO ^RMPFDB1
- +1 DO DELETE
- if $DATA(RMPFOUT)!'$DATA(RMPFBJ)
- GOTO END
- GOTO RMPFSET
- END KILL RMPFB,RMPFBJ,N,D,RMPFBT,POP,I,CT,X,Y,%,%DT,RM
- 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
- DELETE ;;input: RMPFB
- +1 ;;output: None
- +2 KILL RMPFBJ
- +3 WRITE !!,"Enter Order Numbers Separated by Commas: "
- +4 DO READ
- if $DATA(RMPFOUT)
- GOTO DELETEE
- DELE IF $DATA(RMPFQUT)
- WRITE !!,"Select the number(s) to the left of the orders you wish to delete.",!,"Separate numbers with commas."
- GOTO DELETE
- +1 if Y=""
- GOTO DELETEE
- +2 FOR I=1:1
- SET X=$PIECE(Y,",",I)
- if X=""
- QUIT
- IF '$DATA(RMPFB(X))
- SET RMPFQUT=""
- QUIT
- +3 if $DATA(RMPFQUT)
- GOTO DELE
- SET SG=Y
- WRITE !!
- +4 FOR I=1:1
- SET RX=$PIECE(SG,",",I)
- if RX=""
- QUIT
- IF $DATA(RMPFB(RX))
- SET RMPFBJ=RMPFB(RX)
- IF $DATA(^RMPF(791812,RMPFBT,101,RMPFBJ,0))
- SET RMPFX=$PIECE(^(0),U,1)
- DO DEL
- +5 KILL X,Y,I,SG,RX
- QUIT
- DEL IF $DATA(RMPFX)
- IF RMPFX
- IF $DATA(^RMPF(791810,RMPFX,0))
- GOTO DEL0
- +1 WRITE !!?25,$CHAR(7),"*** ORDER DOES NOT EXIST *** "
- GOTO DELETEE
- DEL0 WRITE !!,"Order: "
- SET Y=$PIECE(^RMPF(791810,RMPFX,0),U,1)
- DO DD^%DT
- WRITE Y
- SET X=$PIECE(^RMPF(791810,RMPFX,0),U,2)
- IF X
- IF $DATA(^RMPF(791810.1,X,0))
- WRITE ?$X+5,$PIECE(^(0),U,1)
- +1 WRITE !!,"Are you sure you want to delete this order from the batch? NO// "
- DO READ
- +2 if $DATA(RMPFOUT)
- GOTO DELETEE
- DEL1 IF $DATA(RMPFQUT)
- WRITE !!,"Enter <N> or <RETURN> to continue or <Y> to delete the order."
- GOTO DEL0
- +1 if Y=""
- SET Y="N"
- SET Y=$EXTRACT(Y,1)
- IF "yYnN"'[Y
- SET RMPFQUT=""
- GOTO DEL1
- +2 if "Nn"[Y
- GOTO DELETEE
- DEL2 WRITE !!,"Enter reason for deletion: "
- DO READ
- +1 if $DATA(RMPFOUT)
- GOTO DELETEE
- DEL3 IF $DATA(RMPFQUT)
- WRITE !!,"You must enter a reason for the deletion (3 to 30 characters)."
- GOTO DEL2
- +1 IF $LENGTH(Y)<3!$LENGTH(Y)>30
- SET RMPFQUT=""
- GOTO DEL3
- +2 SET RMPFDLR=Y
- +3 SET X="NOW"
- SET %DT="TR"
- DO ^%DT
- SET RMPFDTD=Y
- +4 SET DIE="^RMPF(791812,"_RMPFBT_",101,"
- SET DA(1)=RMPFBT
- SET DA=RMPFBJ
- +5 SET DR=".02////"_DUZ_";.03////"_RMPFDTD_";.04////"_RMPFDLR
- DO ^DIE
- +6 LOCK ^RMPF(791812,RMPFBT,0)
- SET X=$PIECE(^RMPF(791812,RMPFBT,0),U,4)
- if X
- SET X=X-1
- SET $PIECE(^(0),U,4)=X
- +7 IF X=0
- SET Y=$PIECE(^RMPF(791812,RMPFBT,0),U,2)
- if Y
- KILL ^RMPF(791812,"C",Y,RMPFBT)
- SET Y=$PIECE(^RMPF(791812,RMPFBT,0),U,1)
- KILL ^RMPF(791812,RMPFBT),^RMPF(791812,"B",Y,RMPFBT)
- +8 LOCK
- +9 SET DIE="^RMPF(791810,"
- SET DA=RMPFX
- SET DR=".03///DISAPPROVED;.06////"_RMPFDTD_";.1////"_DUZ_";.11////"_RMPFDTD_";10.02////"_RMPFDLR
- DO ^DIE
- +10 SET DIE="^RMPF(791810,"_RMPFX_",101,"
- SET DA(1)=RMPFX
- +11 SET DR=".17////"_RMPFDTD_";.18///DISAPPROVED;.2////1"
- SET DA=0
- +12 DO ARRAY^RMPFDT2
- FOR
- SET DA=$ORDER(RMPFO(DA))
- if 'DA
- QUIT
- DO ^DIE
- +13 WRITE !!?20,"*** ORDER DELETED FROM BATCH ***"
- HANG 2
- DELETEE KILL RMPFX,RMPFDLR,RMPFDTD,DI,D0,DQ,%DT,DA,DC,DIE,DIC,DA,DR,D,X,Y
- QUIT
