- IBPU ;ALB/CPM - ARCHIVE/PURGING UTILITIES ; 20-APR-92
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ASK(FILE,JOB) ; User prompts to find/archive/purge entries for each data file.
- ; Input: FILE -- Billing Data file number
- ; JOB -- 1 Find Billing Data to Archive
- ; -- 2 Archive Billing Data
- ; -- 3 Purge Billing Data
- ; Output: -1 -- Exit option
- ; 0 -- No action to be taken
- ; 1^a -- Take action.
- ; Optional second piece (a) is ien of
- ; log entry if a restart is required.
- N FNAME,STATUS,Y
- S STATUS=$$LOG($G(FILE)) I 'STATUS W !,"File #",FILE," is not defined." Q 0
- S FNAME=$P($G(^DIC(FILE,0)),"^")
- 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
- S STATUS=STATUS-JOB+1
- Q $S(STATUS>1:$$RESTART(FNAME,FILE,JOB),1:$$START(FNAME,JOB))
- ;
- START(NAME,JOB) ; Start find/archive/purge action?
- ; Input: NAME -- File name
- ; JOB -- same as above (1, 2, or 3)
- ; Output: 1 -- Yes, 0 -- No, -1 -- Exit Option
- N DESC,DIR,DIRUT,DUOUT,DTOUT,Y
- S DESC=$P("find^archive^purge","^",JOB)
- S DIR(0)="Y",DIR("A")="Do you wish to "_DESC_" "_NAME_" file entries"
- S DIR("?",1)="Enter: 'Y' to "_DESC_" "_NAME_" entries"
- S DIR("?",2)=" 'N' to ignore "_$P("find^archiv^purg","^",JOB)_"ing "_NAME_" entries, or"
- S DIR("?")=" '^' to quit this option." D ^DIR
- Q $S($D(DIRUT)!($D(DUOUT))!($D(DTOUT)):-1,Y:1,1:0)
- ;
- RESTART(NAME,FILE,JOB) ; Re-start find/archive action?
- ; Input: NAME -- File name
- ; FILE -- Billing Data file number
- ; JOB -- same as above (only 1 or 2)
- ; Output: 1 -- Yes, 0 -- No, -1 -- Exit Option
- N DIR,DIRUT,DUOUT,DTOUT,Y
- W !,NAME," file entries have already been ",$P("found.^archived.","^",JOB)
- S DIR(0)="Y",DIR("A")="Do you wish to "_$S(JOB=1:"delete your search template and start",1:"archive these entries")_" again"
- S DIR("?",1)="Enter: 'Y' to "_$S(JOB=1:"delete your current search template and search",1:"archive entries")_" again"
- S DIR("?",2)=" 'N' to "_$S(JOB=1:"retain your current search template",1:"ignore archiving this file")_", or"
- S DIR("?")=" '^' to quit this option." D ^DIR
- Q $S($D(DIRUT)!($D(DUOUT))!($D(DTOUT)):-1,Y:"1^"_$$LOGIEN^IBPU1(FILE),1:0)
- ;
- LOG(FILE) ; Determine Log status for a file.
- ; Input: FILE -- Billing Data file number
- ; Output: 0 -- File undefined, or invalid file number
- ; 1 -- No active log entry on file
- ; 2 -- Active log entry on file - entries FOUND
- ; 3 -- Active log entry on file - entries ARCHIVED
- N Y,LOG,LOG1,LOG2
- I '$D(^DIC(+$G(FILE))) S Y=0 G LOGQ
- S DA=$$LOGIEN^IBPU1(FILE)
- S LOG=$G(^IBE(350.6,DA,0)),LOG1=$G(^(1)),LOG2=$G(^(2))
- I $P(LOG,"^",5)'=1 S Y=1
- LOGQ Q $S($D(Y):Y,$P(LOG2,"^",2):3,$P(LOG1,"^",2):2,1:1)
- ;
- NUM() ; How many previous fiscal year's worth of data should be retained?
- ; Input: NONE Output: number of years, or -1 to exit option.
- N DIR,DIRUT,DUOUT,DTOUT,Y
- S DIR("A")="Select the number of previous fiscal year's data to retain: "
- S DIR("?",1)="Please select the number of previous fiscal years' worth of billing"
- S DIR("?")="data that you wish to retain in your system, or '^' to exit."
- S DIR(0)="NA^1:20:0",DIR("B")=1 D ^DIR
- Q $S($D(DIRUT)!($D(DUOUT))!($D(DTOUT)):-1,1:Y)
- ;
- DAT() ; What is the date through which data should be archived?
- ; Input: NONE Output: final date for archiving, or -1 to exit.
- N %DT,DTOUT,X,Y
- S %DT="AEPX",%DT(0)=-$$LAST^IBPFU(1),%DT("A")="Enter the final date through which data should be archived: "
- D ^%DT
- Q Y
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBPU 4006 printed Feb 18, 2025@23:53:05 Page 2
- IBPU ;ALB/CPM - ARCHIVE/PURGING UTILITIES ; 20-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 ;
- ASK(FILE,JOB) ; User prompts to find/archive/purge entries for each data file.
- +1 ; Input: FILE -- Billing Data file number
- +2 ; JOB -- 1 Find Billing Data to Archive
- +3 ; -- 2 Archive Billing Data
- +4 ; -- 3 Purge Billing Data
- +5 ; Output: -1 -- Exit option
- +6 ; 0 -- No action to be taken
- +7 ; 1^a -- Take action.
- +8 ; Optional second piece (a) is ien of
- +9 ; log entry if a restart is required.
- +10 NEW FNAME,STATUS,Y
- +11 SET STATUS=$$LOG($GET(FILE))
- IF 'STATUS
- WRITE !,"File #",FILE," is not defined."
- QUIT 0
- +12 SET FNAME=$PIECE($GET(^DIC(FILE,0)),"^")
- +13 IF (JOB=2&(STATUS=1))!(JOB=3&(STATUS<3))
- WRITE !,"You must ",$SELECT(STATUS=1:"find ",1:"archive "),FNAME," entries before you can ",$SELECT(JOB=2:"archive.",1:"purge.")
- QUIT 0
- +14 SET STATUS=STATUS-JOB+1
- +15 QUIT $SELECT(STATUS>1:$$RESTART(FNAME,FILE,JOB),1:$$START(FNAME,JOB))
- +16 ;
- START(NAME,JOB) ; Start find/archive/purge action?
- +1 ; Input: NAME -- File name
- +2 ; JOB -- same as above (1, 2, or 3)
- +3 ; Output: 1 -- Yes, 0 -- No, -1 -- Exit Option
- +4 NEW DESC,DIR,DIRUT,DUOUT,DTOUT,Y
- +5 SET DESC=$PIECE("find^archive^purge","^",JOB)
- +6 SET DIR(0)="Y"
- SET DIR("A")="Do you wish to "_DESC_" "_NAME_" file entries"
- +7 SET DIR("?",1)="Enter: 'Y' to "_DESC_" "_NAME_" entries"
- +8 SET DIR("?",2)=" 'N' to ignore "_$PIECE("find^archiv^purg","^",JOB)_"ing "_NAME_" entries, or"
- +9 SET DIR("?")=" '^' to quit this option."
- DO ^DIR
- +10 QUIT $SELECT($DATA(DIRUT)!($DATA(DUOUT))!($DATA(DTOUT)):-1,Y:1,1:0)
- +11 ;
- RESTART(NAME,FILE,JOB) ; Re-start find/archive action?
- +1 ; Input: NAME -- File name
- +2 ; FILE -- Billing Data file number
- +3 ; JOB -- same as above (only 1 or 2)
- +4 ; Output: 1 -- Yes, 0 -- No, -1 -- Exit Option
- +5 NEW DIR,DIRUT,DUOUT,DTOUT,Y
- +6 WRITE !,NAME," file entries have already been ",$PIECE("found.^archived.","^",JOB)
- +7 SET DIR(0)="Y"
- SET DIR("A")="Do you wish to "_$SELECT(JOB=1:"delete your search template and start",1:"archive these entries")_" again"
- +8 SET DIR("?",1)="Enter: 'Y' to "_$SELECT(JOB=1:"delete your current search template and search",1:"archive entries")_" again"
- +9 SET DIR("?",2)=" 'N' to "_$SELECT(JOB=1:"retain your current search template",1:"ignore archiving this file")_", or"
- +10 SET DIR("?")=" '^' to quit this option."
- DO ^DIR
- +11 QUIT $SELECT($DATA(DIRUT)!($DATA(DUOUT))!($DATA(DTOUT)):-1,Y:"1^"_$$LOGIEN^IBPU1(FILE),1:0)
- +12 ;
- LOG(FILE) ; Determine Log status for a file.
- +1 ; Input: FILE -- Billing Data file number
- +2 ; Output: 0 -- File undefined, or invalid file number
- +3 ; 1 -- No active log entry on file
- +4 ; 2 -- Active log entry on file - entries FOUND
- +5 ; 3 -- Active log entry on file - entries ARCHIVED
- +6 NEW Y,LOG,LOG1,LOG2
- +7 IF '$DATA(^DIC(+$GET(FILE)))
- SET Y=0
- GOTO LOGQ
- +8 SET DA=$$LOGIEN^IBPU1(FILE)
- +9 SET LOG=$GET(^IBE(350.6,DA,0))
- SET LOG1=$GET(^(1))
- SET LOG2=$GET(^(2))
- +10 IF $PIECE(LOG,"^",5)'=1
- SET Y=1
- LOGQ QUIT $SELECT($DATA(Y):Y,$PIECE(LOG2,"^",2):3,$PIECE(LOG1,"^",2):2,1:1)
- +1 ;
- NUM() ; How many previous fiscal year's worth of data should be retained?
- +1 ; Input: NONE Output: number of years, or -1 to exit option.
- +2 NEW DIR,DIRUT,DUOUT,DTOUT,Y
- +3 SET DIR("A")="Select the number of previous fiscal year's data to retain: "
- +4 SET DIR("?",1)="Please select the number of previous fiscal years' worth of billing"
- +5 SET DIR("?")="data that you wish to retain in your system, or '^' to exit."
- +6 SET DIR(0)="NA^1:20:0"
- SET DIR("B")=1
- DO ^DIR
- +7 QUIT $SELECT($DATA(DIRUT)!($DATA(DUOUT))!($DATA(DTOUT)):-1,1:Y)
- +8 ;
- DAT() ; What is the date through which data should be archived?
- +1 ; Input: NONE Output: final date for archiving, or -1 to exit.
- +2 NEW %DT,DTOUT,X,Y
- +3 SET %DT="AEPX"
- SET %DT(0)=-$$LAST^IBPFU(1)
- SET %DT("A")="Enter the final date through which data should be archived: "
- +4 DO ^%DT
- +5 QUIT Y
