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

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

initial load of WorldVistAEHR
File size: 3.8 KB
Line 
1IBPU ;ALB/CPM - ARCHIVE/PURGING UTILITIES ; 20-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 ;
5ASK(FILE,JOB) ; User prompts to find/archive/purge entries for each data file.
6 ; Input: FILE -- Billing Data file number
7 ; JOB -- 1 Find Billing Data to Archive
8 ; -- 2 Archive Billing Data
9 ; -- 3 Purge Billing Data
10 ; Output: -1 -- Exit option
11 ; 0 -- No action to be taken
12 ; 1^a -- Take action.
13 ; Optional second piece (a) is ien of
14 ; log entry if a restart is required.
15 N FNAME,STATUS,Y
16 S STATUS=$$LOG($G(FILE)) I 'STATUS W !,"File #",FILE," is not defined." Q 0
17 S FNAME=$P($G(^DIC(FILE,0)),"^")
18 I (JOB=2&(STATUS=1))!(JOB=3&(STATUS<3)) W !,"You must ",$S(STATUS=1:"find ",1:"archive "),FNAME," entries before you can ",$S(JOB=2:"archive.",1:"purge.") Q 0
19 S STATUS=STATUS-JOB+1
20 Q $S(STATUS>1:$$RESTART(FNAME,FILE,JOB),1:$$START(FNAME,JOB))
21 ;
22START(NAME,JOB) ; Start find/archive/purge action?
23 ; Input: NAME -- File name
24 ; JOB -- same as above (1, 2, or 3)
25 ; Output: 1 -- Yes, 0 -- No, -1 -- Exit Option
26 N DESC,DIR,DIRUT,DUOUT,DTOUT,Y
27 S DESC=$P("find^archive^purge","^",JOB)
28 S DIR(0)="Y",DIR("A")="Do you wish to "_DESC_" "_NAME_" file entries"
29 S DIR("?",1)="Enter: 'Y' to "_DESC_" "_NAME_" entries"
30 S DIR("?",2)=" 'N' to ignore "_$P("find^archiv^purg","^",JOB)_"ing "_NAME_" entries, or"
31 S DIR("?")=" '^' to quit this option." D ^DIR
32 Q $S($D(DIRUT)!($D(DUOUT))!($D(DTOUT)):-1,Y:1,1:0)
33 ;
34RESTART(NAME,FILE,JOB) ; Re-start find/archive action?
35 ; Input: NAME -- File name
36 ; FILE -- Billing Data file number
37 ; JOB -- same as above (only 1 or 2)
38 ; Output: 1 -- Yes, 0 -- No, -1 -- Exit Option
39 N DIR,DIRUT,DUOUT,DTOUT,Y
40 W !,NAME," file entries have already been ",$P("found.^archived.","^",JOB)
41 S DIR(0)="Y",DIR("A")="Do you wish to "_$S(JOB=1:"delete your search template and start",1:"archive these entries")_" again"
42 S DIR("?",1)="Enter: 'Y' to "_$S(JOB=1:"delete your current search template and search",1:"archive entries")_" again"
43 S DIR("?",2)=" 'N' to "_$S(JOB=1:"retain your current search template",1:"ignore archiving this file")_", or"
44 S DIR("?")=" '^' to quit this option." D ^DIR
45 Q $S($D(DIRUT)!($D(DUOUT))!($D(DTOUT)):-1,Y:"1^"_$$LOGIEN^IBPU1(FILE),1:0)
46 ;
47LOG(FILE) ; Determine Log status for a file.
48 ; Input: FILE -- Billing Data file number
49 ; Output: 0 -- File undefined, or invalid file number
50 ; 1 -- No active log entry on file
51 ; 2 -- Active log entry on file - entries FOUND
52 ; 3 -- Active log entry on file - entries ARCHIVED
53 N Y,LOG,LOG1,LOG2
54 I '$D(^DIC(+$G(FILE))) S Y=0 G LOGQ
55 S DA=$$LOGIEN^IBPU1(FILE)
56 S LOG=$G(^IBE(350.6,DA,0)),LOG1=$G(^(1)),LOG2=$G(^(2))
57 I $P(LOG,"^",5)'=1 S Y=1
58LOGQ Q $S($D(Y):Y,$P(LOG2,"^",2):3,$P(LOG1,"^",2):2,1:1)
59 ;
60NUM() ; How many previous fiscal year's worth of data should be retained?
61 ; Input: NONE Output: number of years, or -1 to exit option.
62 N DIR,DIRUT,DUOUT,DTOUT,Y
63 S DIR("A")="Select the number of previous fiscal year's data to retain: "
64 S DIR("?",1)="Please select the number of previous fiscal years' worth of billing"
65 S DIR("?")="data that you wish to retain in your system, or '^' to exit."
66 S DIR(0)="NA^1:20:0",DIR("B")=1 D ^DIR
67 Q $S($D(DIRUT)!($D(DUOUT))!($D(DTOUT)):-1,1:Y)
68 ;
69DAT() ; What is the date through which data should be archived?
70 ; Input: NONE Output: final date for archiving, or -1 to exit.
71 N %DT,DTOUT,X,Y
72 S %DT="AEPX",%DT(0)=-$$LAST^IBPFU(1),%DT("A")="Enter the final date through which data should be archived: "
73 D ^%DT
74 Q Y
Note: See TracBrowser for help on using the repository browser.