source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBPUDEL.m@ 1259

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.5 KB
Line 
1IBPUDEL ;ALB/CPM - DELETE SEARCH TEMPLATE ENTRIES ; 24-APR-92
2 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5DEL ; Delete Entry From Search Template
6 S IBF=$$SEL G DELQ:'IBF
7 D HOME^%ZIS W @IOF,*13 D HDR S I="",$P(I,"=",81)="" W !,I
8 ;
9 ; - list entries which may be deleted
10 S IBTMDA=+IBD(IBF),(IBN,IBEN)=0 K ^TMP($J,"IBPUDEL")
11 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
12 I 'IBEN G DELQ
13 ;
14 ; - okay to delete?
15 S DIR(0)="Y",DIR("A")="Do you wish to delete this entry"
16 S DIR("?",1)="Enter: 'Y' to delete this entry"
17 S DIR("?")=" 'N' or '^' to quit this option."
18 D ^DIR K DIR
19 ;
20 ; - if okay, update # records and delete entry
21 I Y D
22 . S IBNUMR=$P($G(^IBE(350.6,+$P(IBD(IBF),"^",3),0)),"^",4)
23 . I IBNUMR>1 D Q
24 .. D UPD^IBPU1(+$P(IBD(IBF),"^",3),.04,IBNUMR-1)
25 .. K ^DIBT(IBTMDA,1,+$G(^TMP($J,"IBPUDEL",IBEN))) W !,"This entry has been deleted.",!
26 . D DEL^IBPU1(IBF) ; delete search template
27 . D UPD^IBPU1(+$P(IBD(IBF),"^",3),.05,"/3") ; cancel log entry
28 . W !,"Since this is the last template entry, the template has been deleted, and",!,"the log entry has been cancelled."
29 ;
30DELQ K ^TMP($J,"IBPUDEL"),DIRUT,DTOUT,DUOUT,I,IBD,IBF,IBN,IBNUMR,IBTMDA,X,Y
31 Q
32 ;
33 ;
34SEL() ; Prompt for Search Template.
35 ; Input: NONE
36 ; Output: File number, or 0 if none found/selected.
37 ; If file number is selected, then IBD is returned as
38 ; IBD(file #)=ien of template^status of log^ien of log
39 N I,IBTM,IBTMDA,J,K K IBD
40 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
41 I '$D(IBD) S IBF=0 W !!,"There are no Search templates which are currently active.",! G SELQ
42 S IBF=$O(IBD(0)) I '$O(IBD(IBF)) G SELQ
43 ;
44 ; - display template (file) selections
45 W !,"Select one of the following files where a Search Template has been created:",!
46 S IBF=0 F S IBF=$O(IBD(IBF)) Q:'IBF W !,?1,IBF,?6 D HDR
47 ;
48 ; - select a template
49READ 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
50SELQ Q +IBF
51 ;
52HDR ; Write out a header. Input: IBF -- file name
53 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)
54 Q
55 ;
56DISP ; Display entry from a file. Input: IBF -- file name, IBN -- file entry
57 N C,DATA,ROOT
58 S ROOT=^DIC(IBF,0,"GL"),DATA=$G(@(ROOT_IBN_",0)"))
59 W !,$J(I,2),?5,$E($P($G(^DPT(+$P(DATA,"^",2),0)),"^"),1,22),?30
60 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
61 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
62 W $P($G(^DGCR(399.3,+$P(DATA,"^",7),0)),"^")
63 S Y=$P(DATA,"^",13),C=$P(^DD(399,.13,0),"^",2) D Y^DIQ W ?52,Y
64 W ?71,$$DAT1^IBOUTL($P(DATA,"^",14))
65DISPQ Q
66 ;
67PICK ; Select an entry to delete.
68 ; Input: ^TMP($J,"IBPUDEL", -- possible choices
69 ; Output: IBEN -- null (continue),
70 ; '^' (quit), or
71 ; a successful pick
72ASK 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
73 W ! Q
Note: See TracBrowser for help on using the repository browser.