IBPUDEL.m

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 ---IBPUDEL   3701     printed  Feb 18, 2025@23:53:09                                                                                                                                                                                                     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