IBPUDEL ;ALB/CPM - DELETE SEARCH TEMPLATE ENTRIES ; 24-APR-92
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
DEL ; Delete Entry From Search Template
S IBF=$$SEL G DELQ:'IBF
D HOME^%ZIS W @IOF,*13 D HDR S I="",$P(I,"=",81)="" W !,I
;
; - list entries which may be deleted
S IBTMDA=+IBD(IBF),(IBN,IBEN)=0 K ^TMP($J,"IBPUDEL")
F I=1:1 S IBN=$O(^DIBT(IBTMDA,1,IBN)) D PICK:'IBN Q:'IBN S ^TMP($J,"IBPUDEL",I)=IBN D DISP,PICK:'(I#19) G:IBEN["^" DELQ Q:IBEN
I 'IBEN G DELQ
;
; - okay to delete?
S DIR(0)="Y",DIR("A")="Do you wish to delete this entry"
S DIR("?",1)="Enter: 'Y' to delete this entry"
S DIR("?")=" 'N' or '^' to quit this option."
D ^DIR K DIR
;
; - if okay, update # records and delete entry
I Y D
. S IBNUMR=$P($G(^IBE(350.6,+$P(IBD(IBF),"^",3),0)),"^",4)
. I IBNUMR>1 D Q
.. D UPD^IBPU1(+$P(IBD(IBF),"^",3),.04,IBNUMR-1)
.. K ^DIBT(IBTMDA,1,+$G(^TMP($J,"IBPUDEL",IBEN))) W !,"This entry has been deleted.",!
. D DEL^IBPU1(IBF) ; delete search template
. D UPD^IBPU1(+$P(IBD(IBF),"^",3),.05,"/3") ; cancel log entry
. W !,"Since this is the last template entry, the template has been deleted, and",!,"the log entry has been cancelled."
;
DELQ K ^TMP($J,"IBPUDEL"),DIRUT,DTOUT,DUOUT,I,IBD,IBF,IBN,IBNUMR,IBTMDA,X,Y
Q
;
;
SEL() ; Prompt for Search Template.
; Input: NONE
; Output: File number, or 0 if none found/selected.
; If file number is selected, then IBD is returned as
; IBD(file #)=ien of template^status of log^ien of log
N I,IBTM,IBTMDA,J,K K IBD
F I=350,351,399 S J=$$LOG^IBPU(I) I J>1 S K=$$LOGIEN^IBPU1(I),IBTM=$P($G(^IBE(350.6,K,0)),"^",2) I IBTM]"" S IBTMDA=$O(^DIBT("B",IBTM,0)) I IBTMDA S IBD(I)=IBTMDA_"^"_J_"^"_K
I '$D(IBD) S IBF=0 W !!,"There are no Search templates which are currently active.",! G SELQ
S IBF=$O(IBD(0)) I '$O(IBD(IBF)) G SELQ
;
; - display template (file) selections
W !,"Select one of the following files where a Search Template has been created:",!
S IBF=0 F S IBF=$O(IBD(IBF)) Q:'IBF W !,?1,IBF,?6 D HDR
;
; - select a template
READ W !!,"Select a File Number: " R IBF:DTIME I $T,"^"'[IBF,'$D(IBD(IBF)) W !!," Enter one of the displayed file numbers, or '^' to exit this option." G READ
SELQ Q +IBF
;
HDR ; Write out a header. Input: IBF -- file name
W $P($G(^DIC(IBF,0)),"^"),?35,"Created on ",$$DAT1^IBOUTL(+$G(^IBE(350.6,$P(IBD(IBF),"^",3),1)))," by ",$E($P($G(^VA(200,+$P($G(^(1)),"^",3),0)),"^"),1,22)
Q
;
DISP ; Display entry from a file. Input: IBF -- file name, IBN -- file entry
N C,DATA,ROOT
S ROOT=^DIC(IBF,0,"GL"),DATA=$G(@(ROOT_IBN_",0)"))
W !,$J(I,2),?5,$E($P($G(^DPT(+$P(DATA,"^",2),0)),"^"),1,22),?30
I IBF=350 W $P(DATA,"^",8) S Y=$P(DATA,"^",5),C=$P(^DD(350,.05,0),"^",2) D Y^DIQ W ?54,Y,?67,$$DAT1^IBOUTL($P($G(^IB(IBN,1)),"^",2)) G DISPQ
I IBF=351 W $$DAT1^IBOUTL($P(DATA,"^",3)) S Y=$P(DATA,"^",4),C=$P(^DD(351,.04,0),"^",2) D Y^DIQ W ?44,Y,?59,$$DAT1^IBOUTL($P(DATA,"^",10)) G DISPQ
W $P($G(^DGCR(399.3,+$P(DATA,"^",7),0)),"^")
S Y=$P(DATA,"^",13),C=$P(^DD(399,.13,0),"^",2) D Y^DIQ W ?52,Y
W ?71,$$DAT1^IBOUTL($P(DATA,"^",14))
DISPQ Q
;
PICK ; Select an entry to delete.
; Input: ^TMP($J,"IBPUDEL", -- possible choices
; Output: IBEN -- null (continue),
; '^' (quit), or
; a successful pick
ASK W !!,"Select 1-",$S(IBN:I,1:I-1),", or '^' to exit: " R IBEN:DTIME S:'$T IBEN="^" I "^"'[IBEN,'$D(^TMP($J,"IBPUDEL",IBEN)) W !!," ENTER a number between 1 and ",$S(IBN:I,1:I-1),"." G ASK
W ! Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBPUDEL 3701 printed Dec 13, 2024@02:26:39 Page 2
IBPUDEL ;ALB/CPM - DELETE SEARCH TEMPLATE ENTRIES ; 24-APR-92
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
DEL ; Delete Entry From Search Template
+1 SET IBF=$$SEL
if 'IBF
GOTO DELQ
+2 DO HOME^%ZIS
WRITE @IOF,*13
DO HDR
SET I=""
SET $PIECE(I,"=",81)=""
WRITE !,I
+3 ;
+4 ; - list entries which may be deleted
+5 SET IBTMDA=+IBD(IBF)
SET (IBN,IBEN)=0
KILL ^TMP($JOB,"IBPUDEL")
+6 FOR I=1:1
SET IBN=$ORDER(^DIBT(IBTMDA,1,IBN))
if 'IBN
DO PICK
if 'IBN
QUIT
SET ^TMP($JOB,"IBPUDEL",I)=IBN
DO DISP
if '(I#19)
DO PICK
if IBEN["^"
GOTO DELQ
if IBEN
QUIT
+7 IF 'IBEN
GOTO DELQ
+8 ;
+9 ; - okay to delete?
+10 SET DIR(0)="Y"
SET DIR("A")="Do you wish to delete this entry"
+11 SET DIR("?",1)="Enter: 'Y' to delete this entry"
+12 SET DIR("?")=" 'N' or '^' to quit this option."
+13 DO ^DIR
KILL DIR
+14 ;
+15 ; - if okay, update # records and delete entry
+16 IF Y
Begin DoDot:1
+17 SET IBNUMR=$PIECE($GET(^IBE(350.6,+$PIECE(IBD(IBF),"^",3),0)),"^",4)
+18 IF IBNUMR>1
Begin DoDot:2
+19 DO UPD^IBPU1(+$PIECE(IBD(IBF),"^",3),.04,IBNUMR-1)
+20 KILL ^DIBT(IBTMDA,1,+$GET(^TMP($JOB,"IBPUDEL",IBEN)))
WRITE !,"This entry has been deleted.",!
End DoDot:2
QUIT
+21 ; delete search template
DO DEL^IBPU1(IBF)
+22 ; cancel log entry
DO UPD^IBPU1(+$PIECE(IBD(IBF),"^",3),.05,"/3")
+23 WRITE !,"Since this is the last template entry, the template has been deleted, and",!,"the log entry has been cancelled."
End DoDot:1
+24 ;
DELQ KILL ^TMP($JOB,"IBPUDEL"),DIRUT,DTOUT,DUOUT,I,IBD,IBF,IBN,IBNUMR,IBTMDA,X,Y
+1 QUIT
+2 ;
+3 ;
SEL() ; Prompt for Search Template.
+1 ; Input: NONE
+2 ; Output: File number, or 0 if none found/selected.
+3 ; If file number is selected, then IBD is returned as
+4 ; IBD(file #)=ien of template^status of log^ien of log
+5 NEW I,IBTM,IBTMDA,J,K
KILL IBD
+6 FOR I=350,351,399
SET J=$$LOG^IBPU(I)
IF J>1
SET K=$$LOGIEN^IBPU1(I)
SET IBTM=$PIECE($GET(^IBE(350.6,K,0)),"^",2)
IF IBTM]""
SET IBTMDA=$ORDER(^DIBT("B",IBTM,0))
IF IBTMDA
SET IBD(I)=IBTMDA_"^"_J_"^"_K
+7 IF '$DATA(IBD)
SET IBF=0
WRITE !!,"There are no Search templates which are currently active.",!
GOTO SELQ
+8 SET IBF=$ORDER(IBD(0))
IF '$ORDER(IBD(IBF))
GOTO SELQ
+9 ;
+10 ; - display template (file) selections
+11 WRITE !,"Select one of the following files where a Search Template has been created:",!
+12 SET IBF=0
FOR
SET IBF=$ORDER(IBD(IBF))
if 'IBF
QUIT
WRITE !,?1,IBF,?6
DO HDR
+13 ;
+14 ; - select a template
READ WRITE !!,"Select a File Number: "
READ IBF:DTIME
IF $TEST
IF "^"'[IBF
IF '$DATA(IBD(IBF))
WRITE !!," Enter one of the displayed file numbers, or '^' to exit this option."
GOTO READ
SELQ QUIT +IBF
+1 ;
HDR ; Write out a header. Input: IBF -- file name
+1 WRITE $PIECE($GET(^DIC(IBF,0)),"^"),?35,"Created on ",$$DAT1^IBOUTL(+$GET(^IBE(350.6,$PIECE(IBD(IBF),"^",3),1)))," by ",$EXTRACT($PIECE($GET(^VA(200,+$PIECE($GET(^(1)),"^",3),0)),"^"),1,22)
+2 QUIT
+3 ;
DISP ; Display entry from a file. Input: IBF -- file name, IBN -- file entry
+1 NEW C,DATA,ROOT
+2 SET ROOT=^DIC(IBF,0,"GL")
SET DATA=$GET(@(ROOT_IBN_",0)"))
+3 WRITE !,$JUSTIFY(I,2),?5,$EXTRACT($PIECE($GET(^DPT(+$PIECE(DATA,"^",2),0)),"^"),1,22),?30
+4 IF IBF=350
WRITE $PIECE(DATA,"^",8)
SET Y=$PIECE(DATA,"^",5)
SET C=$PIECE(^DD(350,.05,0),"^",2)
DO Y^DIQ
WRITE ?54,Y,?67,$$DAT1^IBOUTL($PIECE($GET(^IB(IBN,1)),"^",2))
GOTO DISPQ
+5 IF IBF=351
WRITE $$DAT1^IBOUTL($PIECE(DATA,"^",3))
SET Y=$PIECE(DATA,"^",4)
SET C=$PIECE(^DD(351,.04,0),"^",2)
DO Y^DIQ
WRITE ?44,Y,?59,$$DAT1^IBOUTL($PIECE(DATA,"^",10))
GOTO DISPQ
+6 WRITE $PIECE($GET(^DGCR(399.3,+$PIECE(DATA,"^",7),0)),"^")
+7 SET Y=$PIECE(DATA,"^",13)
SET C=$PIECE(^DD(399,.13,0),"^",2)
DO Y^DIQ
WRITE ?52,Y
+8 WRITE ?71,$$DAT1^IBOUTL($PIECE(DATA,"^",14))
DISPQ QUIT
+1 ;
PICK ; Select an entry to delete.
+1 ; Input: ^TMP($J,"IBPUDEL", -- possible choices
+2 ; Output: IBEN -- null (continue),
+3 ; '^' (quit), or
+4 ; a successful pick
ASK WRITE !!,"Select 1-",$SELECT(IBN:I,1:I-1),", or '^' to exit: "
READ IBEN:DTIME
if '$TEST
SET IBEN="^"
IF "^"'[IBEN
IF '$DATA(^TMP($JOB,"IBPUDEL",IBEN))
WRITE !!," ENTER a number between 1 and ",$SELECT(IBN:I,1:I-1),"."
GOTO ASK
+1 WRITE !
QUIT
