DG272PT ;alb/maw-DG*5.3*272 POST-INSTALL TO PURGE IVM DATA ;2/1/2000 [ 01/24/2002 2:28 PM ]
;;5.3;Registration;**272,1015**;Aug 13, 1993;Build 21
;IHS/ANMC/LJF 4/12/2000 quit added to bypass purge for IHS sites
;
; This routine is the post-installation for patch DG*5.3*272.
;
; The purge process completed by this routine is required by the
; sharing agreement between VHA, Internal Revenue Service and the
; Social Security Administration. The specific criteria for a
; record to be purged of income data is:
;
; Income years 1992 through 1996
; Date range = 1/1/93 through 12/31/97
; Status of test = Category C
; Source of Income Test = IVM
;
; Data will be "purged" by setting the values of specific fields
; equal to null. The list of fields can be found at the end of
; the routine ^DG272PT1.
;
; record number variables:
; DGMTIE21 = record number in 408.21 (INDIVIDUAL ANNUAL INCOME)
; DGMTIE22 = record number in 408.22 (INCOME RELATION)
; DGMTIE31 = record number in 408.31 (ANNUAL MEANS TEST)
;
; ^XTMP("DGMTPCT",income year) tracks the number of records processed:
; $P(^(income year),U,1)=records during purge process
; $P(^(income year),U,2)=records during close process
; ^XTMP("DGMTPERR") contains error messages returned from FM DBS calls:
; ^XTMP("DGMTPERR",file#,record#,field#,n)=error message
;
POST ;
; add entry to the IVM CASE CLOSURE REASON file (#301.93)
D CLOSER
;
; post-install set up checkpoints and tracking global...
N %,I,X,X1,X2
I $D(XPDNM) D
.; checkpoints for part 1...
.I $$VERCP^XPDUTL("DGMTIDT")'>0 D
..S %=$$NEWCP^XPDUTL("DGMTIDT","","-2980101")
.I $$VERCP^XPDUTL("DGMTDFN")'>0 D
..S %=$$NEWCP^XPDUTL("DGMTDFN","",0)
.;
.; checkpoints for part 2...
.I $$VERCP^XPDUTL("DGDATE")'>0 D
..S %=$$NEWCP^XPDUTL("DGDATE","","2910000")
.I $$VERCP^XPDUTL("DGDFN")'>0 D
..S %=$$NEWCP^XPDUTL("DGDFN","",0)
;
; initialize tracking global (see text above for description)...
F I="DGMTPCT","DGMTPERR" D
.I $D(^XTMP(I)) Q
.S X1=DT
.S X2=30
.D C^%DTC
.S ^XTMP(I,0)=X_"^"_$$DT^XLFDT_"^DG*5.3*272 POST-INSTALL "_$S(I="DGMTPCT":"record count",1:"filing errors")
I '$D(^XTMP("DGMTPCT",292)) F I=292:1:296 S ^XTMP("DGMTPCT",I)="0^0"
;
EN ; begin processing...
N %
; check status of part 1 (purge data)...
I $D(XPDNM) S %=$$VERCP^XPDUTL("DGMTIDT")
I $G(%)="" S %=0
I %=0 D EN1
;
; check status of part 2 (close cases)...
I $D(XPDNM) S %=$$VERCP^XPDUTL("DGDATE")
I $G(%)="" S %=0
I %=0 D EN^DG272PT2
Q
;
EN1 ; begin purge...
D BMES^XPDUTL("POST INSTALLATION PROCESSING")
D BMES^XPDUTL("Statistics for each income year 1992-1996 will be kept")
D MES^XPDUTL("during this purge, and during the case closure process.")
D MES^XPDUTL("Once the post-install is completed, a mail message will")
D MES^XPDUTL("be sent that will report the count of records, by income")
D MES^XPDUTL("year, from which data was purged and the number of records")
D MES^XPDUTL("closed. Additionally, the report will contain notes")
D MES^XPDUTL("about any errors encountered during the post-installation.")
D BMES^XPDUTL("Beginning data purge process "_$$FMTE^XLFDT($$NOW^XLFDT))
;
I '$D(XPDNM) S DGMTIDT="-2980101"
I $D(XPDNM) S DGMTIDT=$$PARCP^XPDUTL("DGMTIDT"),DGMTDFN=$$PARCP^XPDUTL("DGMTDFN")
F S DGMTIDT=$O(^DGMT(408.31,"AS",1,6,DGMTIDT)) Q:DGMTIDT=""!($E(DGMTIDT,2,8)<2930101) D
.S:'$D(DGMTDFN) DGMTDFN=0
.F S DGMTDFN=$O(^DGMT(408.31,"AS",1,6,DGMTIDT,DGMTDFN)) Q:'DGMTDFN D
..S DGMTIE31=0
..F S DGMTIE31=$O(^DGMT(408.31,"AS",1,6,DGMTIDT,DGMTDFN,DGMTIE31)) Q:'DGMTIE31 D
...;
...; quit if already purged...
...I $G(^DGMT(408.31,DGMTIE31,"PURGE"))'="" Q
...;
...; source of income test must be IVM...
...S DGMTDATA=$G(^DGMT(408.31,DGMTIE31,0))
...I $$SRCE^DG272PT1(+$P(DGMTDATA,U,23))'="IVM" K DGMTDATA Q
...K DGMTDATA
...;
...; edit this record in file 408.31...
...S DGFILERR=0
...D EDIT^DG272PT1("408.31",DGMTIE31,.DGFILERR)
...;
...; go to file 408.22...
...S DGMTIE21=0
...F S DGMTIE21=$O(^DGMT(408.22,"AMT",DGMTIE31,DGMTDFN,DGMTIE21)) Q:'DGMTIE21 D
....S DGMTIE22=0
....F S DGMTIE22=$O(^DGMT(408.22,"AMT",DGMTIE31,DGMTDFN,DGMTIE21,DGMTIE22)) Q:'DGMTIE22 D
.....;
.....; edit the record in 408.22...
.....S DGFILERR=0
.....D EDIT^DG272PT1("408.22",DGMTIE22,.DGFILERR)
.....;
.....; use pointer from 408.22 to 408.21 and edit the
.....; record over there...
.....S DGFILERR=0
.....D EDIT^DG272PT1("408.21",DGMTIE21,.DGFILERR)
....K DGMTIE22
...K DGMTIE21
...I '$G(DGFILERR) D COUNT^DG272PT1(DGMTIDT)
..I $D(XPDNM) S %=$$UPCP^XPDUTL("DGMTDFN",DGMTDFN)
..K DGMTIE31
.I $D(XPDNM) S %=$$UPCP^XPDUTL("DGMTIDT",DGMTIDT)
.K DGMTDFN,DGFILERR
K DGMTIDT
;
; clean up and finish...
I $D(XPDNM) S %=$$COMCP^XPDUTL("DGMTIDT")
D MES^XPDUTL(" >>purge process completed "_$$FMTE^XLFDT($$NOW^XLFDT))
Q
;
;
CLOSER ; Add entries to the IVM CASE CLOSURE REASON (#301.93) file
D BMES^XPDUTL(">>> Adding new entry to IVM CASE CLOSURE REASON (#301.93) file")
;
; - if entry already there, display msg and quit
I $O(^IMV(301.93,"B","OLD CASE NO ACTION",0)) D Q
.D MES^XPDUTL(" *** Entry already on file - current values not overwritten ***")
;
; - add new entry to (#301.93) file
F IVMX="OLD CASE NO ACTION" D
.Q:'$D(^IVM(301.93)) ;quit if IHS site;IHS/ANMC/LJF 4/12/2000
.Q:$O(^IVM(301.93,"B",IVMX,0))
.S DIC="^IVM(301.93,",DIC(0)="",DLAYGO=301.93,X=IVMX
.K DD,DO D FILE^DICN
;
D MES^XPDUTL(" Entry has been added")
;
CLOSERQ K DIC,DLAYGO,IVMX,X,Y
Q
DG272PT ;alb/maw-DG*5.3*272 POST-INSTALL TO PURGE IVM DATA ;2/1/2000 [ 01/24/2002 2:28 PM ]
+1 ;;5.3;Registration;**272,1015**;Aug 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 4/12/2000 quit added to bypass purge for IHS sites
+3 ;
+4 ; This routine is the post-installation for patch DG*5.3*272.
+5 ;
+6 ; The purge process completed by this routine is required by the
+7 ; sharing agreement between VHA, Internal Revenue Service and the
+8 ; Social Security Administration. The specific criteria for a
+9 ; record to be purged of income data is:
+10 ;
+11 ; Income years 1992 through 1996
+12 ; Date range = 1/1/93 through 12/31/97
+13 ; Status of test = Category C
+14 ; Source of Income Test = IVM
+15 ;
+16 ; Data will be "purged" by setting the values of specific fields
+17 ; equal to null. The list of fields can be found at the end of
+18 ; the routine ^DG272PT1.
+19 ;
+20 ; record number variables:
+21 ; DGMTIE21 = record number in 408.21 (INDIVIDUAL ANNUAL INCOME)
+22 ; DGMTIE22 = record number in 408.22 (INCOME RELATION)
+23 ; DGMTIE31 = record number in 408.31 (ANNUAL MEANS TEST)
+24 ;
+25 ; ^XTMP("DGMTPCT",income year) tracks the number of records processed:
+26 ; $P(^(income year),U,1)=records during purge process
+27 ; $P(^(income year),U,2)=records during close process
+28 ; ^XTMP("DGMTPERR") contains error messages returned from FM DBS calls:
+29 ; ^XTMP("DGMTPERR",file#,record#,field#,n)=error message
+30 ;
POST ;
+1 ; add entry to the IVM CASE CLOSURE REASON file (#301.93)
+2 DO CLOSER
+3 ;
+4 ; post-install set up checkpoints and tracking global...
+5 NEW %,I,X,X1,X2
+6 IF $DATA(XPDNM)
Begin DoDot:1
+7 ; checkpoints for part 1...
+8 IF $$VERCP^XPDUTL("DGMTIDT")'>0
Begin DoDot:2
+9 SET %=$$NEWCP^XPDUTL("DGMTIDT","","-2980101")
End DoDot:2
+10 IF $$VERCP^XPDUTL("DGMTDFN")'>0
Begin DoDot:2
+11 SET %=$$NEWCP^XPDUTL("DGMTDFN","",0)
End DoDot:2
+12 ;
+13 ; checkpoints for part 2...
+14 IF $$VERCP^XPDUTL("DGDATE")'>0
Begin DoDot:2
+15 SET %=$$NEWCP^XPDUTL("DGDATE","","2910000")
End DoDot:2
+16 IF $$VERCP^XPDUTL("DGDFN")'>0
Begin DoDot:2
+17 SET %=$$NEWCP^XPDUTL("DGDFN","",0)
End DoDot:2
End DoDot:1
+18 ;
+19 ; initialize tracking global (see text above for description)...
+20 FOR I="DGMTPCT","DGMTPERR"
Begin DoDot:1
+21 IF $DATA(^XTMP(I))
QUIT
+22 SET X1=DT
+23 SET X2=30
+24 DO C^%DTC
+25 SET ^XTMP(I,0)=X_"^"_$$DT^XLFDT_"^DG*5.3*272 POST-INSTALL "_$S(I="DGMTPCT":"record count",1:"filing errors")
End DoDot:1
+26 IF '$DATA(^XTMP("DGMTPCT",292))
FOR I=292:1:296
SET ^XTMP("DGMTPCT",I)="0^0"
+27 ;
EN ; begin processing...
+1 NEW %
+2 ; check status of part 1 (purge data)...
+3 IF $DATA(XPDNM)
SET %=$$VERCP^XPDUTL("DGMTIDT")
+4 IF $GET(%)=""
SET %=0
+5 IF %=0
DO EN1
+6 ;
+7 ; check status of part 2 (close cases)...
+8 IF $DATA(XPDNM)
SET %=$$VERCP^XPDUTL("DGDATE")
+9 IF $GET(%)=""
SET %=0
+10 IF %=0
DO EN^DG272PT2
+11 QUIT
+12 ;
EN1 ; begin purge...
+1 DO BMES^XPDUTL("POST INSTALLATION PROCESSING")
+2 DO BMES^XPDUTL("Statistics for each income year 1992-1996 will be kept")
+3 DO MES^XPDUTL("during this purge, and during the case closure process.")
+4 DO MES^XPDUTL("Once the post-install is completed, a mail message will")
+5 DO MES^XPDUTL("be sent that will report the count of records, by income")
+6 DO MES^XPDUTL("year, from which data was purged and the number of records")
+7 DO MES^XPDUTL("closed. Additionally, the report will contain notes")
+8 DO MES^XPDUTL("about any errors encountered during the post-installation.")
+9 DO BMES^XPDUTL("Beginning data purge process "_$$FMTE^XLFDT($$NOW^XLFDT))
+10 ;
+11 IF '$DATA(XPDNM)
SET DGMTIDT="-2980101"
+12 IF $DATA(XPDNM)
SET DGMTIDT=$$PARCP^XPDUTL("DGMTIDT")
SET DGMTDFN=$$PARCP^XPDUTL("DGMTDFN")
+13 FOR
SET DGMTIDT=$ORDER(^DGMT(408.31,"AS",1,6,DGMTIDT))
IF DGMTIDT=""!($EXTRACT(DGMTIDT,2,8)<2930101)
QUIT
Begin DoDot:1
+14 IF '$DATA(DGMTDFN)
SET DGMTDFN=0
+15 FOR
SET DGMTDFN=$ORDER(^DGMT(408.31,"AS",1,6,DGMTIDT,DGMTDFN))
IF 'DGMTDFN
QUIT
Begin DoDot:2
+16 SET DGMTIE31=0
+17 FOR
SET DGMTIE31=$ORDER(^DGMT(408.31,"AS",1,6,DGMTIDT,DGMTDFN,DGMTIE31))
IF 'DGMTIE31
QUIT
Begin DoDot:3
+18 ;
+19 ; quit if already purged...
+20 IF $GET(^DGMT(408.31,DGMTIE31,"PURGE"))'=""
QUIT
+21 ;
+22 ; source of income test must be IVM...
+23 SET DGMTDATA=$GET(^DGMT(408.31,DGMTIE31,0))
+24 IF $$SRCE^DG272PT1(+$PIECE(DGMTDATA,U,23))'="IVM"
KILL DGMTDATA
QUIT
+25 KILL DGMTDATA
+26 ;
+27 ; edit this record in file 408.31...
+28 SET DGFILERR=0
+29 DO EDIT^DG272PT1("408.31",DGMTIE31,.DGFILERR)
+30 ;
+31 ; go to file 408.22...
+32 SET DGMTIE21=0
+33 FOR
SET DGMTIE21=$ORDER(^DGMT(408.22,"AMT",DGMTIE31,DGMTDFN,DGMTIE21))
IF 'DGMTIE21
QUIT
Begin DoDot:4
+34 SET DGMTIE22=0
+35 FOR
SET DGMTIE22=$ORDER(^DGMT(408.22,"AMT",DGMTIE31,DGMTDFN,DGMTIE21,DGMTIE22))
IF 'DGMTIE22
QUIT
Begin DoDot:5
+36 ;
+37 ; edit the record in 408.22...
+38 SET DGFILERR=0
+39 DO EDIT^DG272PT1("408.22",DGMTIE22,.DGFILERR)
+40 ;
+41 ; use pointer from 408.22 to 408.21 and edit the
+42 ; record over there...
+43 SET DGFILERR=0
+44 DO EDIT^DG272PT1("408.21",DGMTIE21,.DGFILERR)
End DoDot:5
+45 KILL DGMTIE22
End DoDot:4
+46 KILL DGMTIE21
+47 IF '$GET(DGFILERR)
DO COUNT^DG272PT1(DGMTIDT)
End DoDot:3
+48 IF $DATA(XPDNM)
SET %=$$UPCP^XPDUTL("DGMTDFN",DGMTDFN)
+49 KILL DGMTIE31
End DoDot:2
+50 IF $DATA(XPDNM)
SET %=$$UPCP^XPDUTL("DGMTIDT",DGMTIDT)
+51 KILL DGMTDFN,DGFILERR
End DoDot:1
+52 KILL DGMTIDT
+53 ;
+54 ; clean up and finish...
+55 IF $DATA(XPDNM)
SET %=$$COMCP^XPDUTL("DGMTIDT")
+56 DO MES^XPDUTL(" >>purge process completed "_$$FMTE^XLFDT($$NOW^XLFDT))
+57 QUIT
+58 ;
+59 ;
CLOSER ; Add entries to the IVM CASE CLOSURE REASON (#301.93) file
+1 DO BMES^XPDUTL(">>> Adding new entry to IVM CASE CLOSURE REASON (#301.93) file")
+2 ;
+3 ; - if entry already there, display msg and quit
+4 IF $ORDER(^IMV(301.93,"B","OLD CASE NO ACTION",0))
Begin DoDot:1
+5 DO MES^XPDUTL(" *** Entry already on file - current values not overwritten ***")
End DoDot:1
QUIT
+6 ;
+7 ; - add new entry to (#301.93) file
+8 FOR IVMX="OLD CASE NO ACTION"
Begin DoDot:1
+9 ;quit if IHS site;IHS/ANMC/LJF 4/12/2000
IF '$DATA(^IVM(301.93))
QUIT
+10 IF $ORDER(^IVM(301.93,"B",IVMX,0))
QUIT
+11 SET DIC="^IVM(301.93,"
SET DIC(0)=""
SET DLAYGO=301.93
SET X=IVMX
+12 KILL DD,DO
DO FILE^DICN
End DoDot:1
+13 ;
+14 DO MES^XPDUTL(" Entry has been added")
+15 ;
CLOSERQ KILL DIC,DLAYGO,IVMX,X,Y
+1 QUIT
