DG53285 ;ALB/PAK-DG*5.3*285 POST-INSTALL TO CLEAN MEANS TEST ;4/24/2000
;;5.3;Registration;**285**;Aug 13, 1993
;
; This routine is the post installation for patch DG*5.3*285
;
; The clean up is required as there is a number of redundant entries
; with a STATUS (#.03) of 'NO LONGER REQUIRED' in the Annual Means
; Test file (408.31). These were created due to the presence of a
; REQUIRED test which was primary for the current income year at the
; time the means test was uploaded.
;
; In addition, if there is a REQUIRED test present within 365 days of
; the means test under review which is primary then this is set to
; NON primary.
;
; Finally, the DG MEANS TEST DRIVER protocol is called.
;
;
; ^XTMP("DG-MTIY",MTIY) track number of records processed:
; ^XTMP("DG-MTERR") contains error messages returned from FM DBS calls:
; ^XTMP("DG-MTERR",file#,record#,field#,n)=error message
;
POST ;
; post-install set up checkpoints and tracking global...
N %,I,X,X1,X2
I $D(XPDNM) D
.; checkpoints
.I $$VERCP^XPDUTL("DGMTIDT")'>0 D
..S %=$$NEWCP^XPDUTL("DGMTIDT","","-9999999")
.I $$VERCP^XPDUTL("DGDFN")'>0 D
..S %=$$NEWCP^XPDUTL("DGDFN","",0)
.;
;
; initialize tracking global (see text above for description)...
F I="MTIY","MTERR" D
.I $D(^XTMP(I)) Q
.S X1=DT
.S X2=30
.D C^%DTC
.S ^XTMP("DG-"_I,0)=X_"^"_$$DT^XLFDT_"^DG*5.3*285 POST-INSTALL "_$S(I="MTIY":"record count",1:"filing errors")
;
EN ; begin processing...
N %
; check status and if root checkpoint has not completed start clean up
I $D(XPDNM) S %=$$VERCP^XPDUTL("DGMTIDT")
I $G(%)="" S %=0
I %=0 D EN1
Q
;
EN1 ; begin purge...
; write message to installation device and to INSTALL file (#9.7)
D BMES^XPDUTL("POST INSTALLATION PROCESSING")
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 means test entries were purged.")
D MES^XPDUTL("Additionally, the report will contain notes")
D MES^XPDUTL("about any errors encountered during the post-installation.")
D BMES^XPDUTL("Beginning purge process "_$$FMTE^XLFDT($$NOW^XLFDT))
;
; process control body
N DGMTIDT,DGDFN,STA,YR,FILERR,MTIEN
;
I '$D(XPDNM) S DGMTIDT=-99999999
I $D(XPDNM) S DGMTIDT=$$PARCP^XPDUTL("DGMTIDT"),DGDFN=$$PARCP^XPDUTL("DGDFN")
S STA=$P($$SITE^VASITE,"^",3)
F S DGMTIDT=$O(^DGMT(408.31,"AS",1,3,DGMTIDT)) Q:'DGMTIDT!(DGMTIDT>-2980101) D
. S:'$D(DGDFN) DGDFN=0
. S YR=$E(DGMTIDT,2,4) ; get current mean test year
. F S DGDFN=$O(^DGMT(408.31,"AS",1,3,DGMTIDT,DGDFN)) Q:DGDFN="" D
. . N FILERR
. . ;
. . ; get primary means test for this year
. . S NODE=$$LST^DGMTU(DGDFN,YR_"1231")
. . ;
. . ; - if primary means test has a STATUS of 'No Longer Required' and
. . ; it has the same MEANS TEST DATE as the current test then delete
. . ; all 'No Longer Required' tests for this date except the primary
. . ; test.
. . ; - otherwise, delete all 'No Longer Required' means test for this
. . ; date except the last entry.
. . I $P(NODE,U,4)="N",($P(NODE,U,2)=-DGMTIDT) S MTIEN=+NODE
. . E S MTIEN=$O(^DGMT(408.31,"AS",1,3,DGMTIDT,DGDFN,""),-1)
. . D DELMT(DGMTIDT,DGDFN,MTIEN,.FILERR)
. . ;
. . ; If 'No Longer Required' test then change 'Required'
. . ; primary test for next Means Test year to Non-Primary and update
. . ; STATUS of means test for current date
. . D RQ2NPRM(-DGMTIDT,DGDFN,STA,YR,NODE,.FILERR)
. . ;
. . ; if error then update temporary store
. . I $G(FILERR) M ^XTMP("DG-MTERR")=FILERR
. . ; update check point with patient ID
. . I $D(XPDNM) S %=$$UPCP^XPDUTL("DGDFN",DGDFN)
. ; update check point with means test inverse date
. I $D(XPDNM) S %=$$UPCP^XPDUTL("DGMTIDT",DGMTIDT)
;
; send mailman msg to user/HEC with results
D MAIL^DG53285M
I $D(XPDNM) S %=$$COMCP^XPDUTL("DGMTIDT")
D MES^XPDUTL(" >>purge process completed "_$$FMTE^XLFDT($$NOW^XLFDT))
Q
;
DELMT(MTIDT,DFN,ENTR,ERRS) ;
; Input:
; MTIDT - Inverse Means Tets Date
; DFN - Patient identifier
; ENTR - Entry # to ignore
; ERRS - DBS file error {by reference}
;
N IEN,ERR
;
S IEN=0
F S IEN=$O(^DGMT(408.31,"AS",1,3,MTIDT,DFN,IEN)) Q:IEN="" D
. Q:IEN=ENTR
. I '$$EN^IVMCMD(IEN) S ERRS(408.31,IEN,"ALL")="Unable to delete means test" Q
. ; increment purged count for income year
. D COUNT(MTIDT)
Q
;
RQ2NPRM(IDT,DFN,STA,YR,NODE,ERRS) ; change Required test to NON primary
;
; Input:
; IDT - Means Test Date
; DFN - Patient identifier
; ERRS - DBS file error {by reference}
; STA - Station number
; YR - Means Test year
; NODE - Last Primary test prior to end of Means Test year (YR)
;
N NODE1,NODE2,DATA,REC31,ERR,DGADDF,DGREQF
;
; get primary test for next year
S NODE1=$$LST^DGMTU(DFN,YR+1_"1231")
;
; 1. if there is no Primary test for the year in which the
; remaining 'No Longer Required' test began then make it
; primary.
; 2. if primary means test for for subsequent year is Required,
; is within 365 days of current means test date and this site
; conducted test then make primary means test NON primary.
; 3. if this site conducted test then change check if test
; is required. If it is required then the STATUS of the
; single remaining No Longer Required means test for this date
; will equal the value of the TEST-DETERMINED STATUS.
;
; (1) determine is 'No Longer Required' test should be primary
S REC31=$O(^DGMT(408.31,"AS",1,3,-IDT,DFN,""))
I +REC31,(+$E($P(NODE,U,2),1,3)<$E($P(^DGMT(408.31,REC31,0),U),1,3)) D
. S DATA(2)=1
. I '$$UPD^DGENDBS(408.31,REC31,.DATA,.ERR) S:$D(ERR) ERRS(408.31,REC31,2)=ERR
.
; (2) determine if subsequent year test should be Non primary
I $P(NODE1,U,2)>(YR_1231),($P(NODE1,U,4)="R"),$$SCOPE($P(NODE1,U,2),IDT) D
. ; set REQUIRED test to NON primary
. S DATA(2)=0
. I '$$UPD^DGENDBS(408.31,+NODE1,.DATA,.ERR) S:$D(ERR) ERRS(408.31,+NODE1,2)=ERR Q
;
; (3) Check if remaining No Longer Required test for this date is
; Required
Q:REC31=""
S NODE2=$G(^DGMT(408.31,REC31,2))
Q:$P(NODE2,U,5)'=STA
D REQ(DFN,REC31,3,IDT)
Q
;
SCOPE(X1,X2) ; Check if dates within 365 days of one another
D ^%DTC
I X>365 Q 0
E Q 1
Q
;
COUNT(DATE) ; update process tracking mechanisms...
; Input:
; DATE = inverse date from "AS" x-ref in 408.31
;
N %,IY
S IY=$E(DATE,2,4)-1
S ^XTMP("DG-MTIY",IY)=+$G(^XTMP("DG-MTIY",IY))+1
Q
;
REQ(DFN,DGMTI,DGCS,IDT) ; Determine if test is Required
;
; ** amended copy of EN^DGMTR as check for latest Primary **
; ** test is not valid for this cleanup. **
;
; Input:
; DFN - Patient ID
; DGMTI - Annual Means Test IEN
; DGCS - Annual Means Test Status
; IDT - Means Test Date
;
; Output:
; DGREQF - Means Test Require Flag
; (1 if required and 0 if not required)
; DGDOM1 - DOM Patient Flag (defined and set to 1 if
; patient currently on a DOM ward)
;
N DGDOM,DGMT0,DGMTYPT,OLD,DGRGAUTO,DGQSENT,DGMSGF
;
S (DGMSGF,DGQSENT,DGREQF)=0,(OLD,DGMTYPT)=1
I $D(^DPT(DFN,.36)) S X=^(.36) D
. I $P($G(^DIC(8,+X,0)),"^",9)=5!($$SC^DGMTR(DFN)) S DGREQF=1
. I $P(X,"^",2),$P(X,"^",2)<3 S DGREQF=0
I DGREQF S:$G(^DPT(DFN,.38)) DGREQF=0
I DGREQF D DOM^DGMTR S:$G(DGDOM) DGREQF=0
S DGMT0=$G(^DGMT(408.31,DGMTI,0))
I DGCS S OLD=$$OLD^DGMTU4(IDT)
;
D
.I DGREQF,DGCS=3,'OLD D REQ^DGMTR Q
.I DGREQF,'$G(DGADDF),(('DGCS)!(OLD)) D ADD^DGMTR Q
.I 'DGREQF,DGCS,DGCS'=3,'$G(DGDOM) D NOL^DGMTR Q
;
;be sure to check whether or not patient is subject to RX copay!
;
D EN^DGMTCOR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53285 7852 printed Apr 09, 2024@21:38:12 Page 2
DG53285 ;ALB/PAK-DG*5.3*285 POST-INSTALL TO CLEAN MEANS TEST ;4/24/2000
+1 ;;5.3;Registration;**285**;Aug 13, 1993
+2 ;
+3 ; This routine is the post installation for patch DG*5.3*285
+4 ;
+5 ; The clean up is required as there is a number of redundant entries
+6 ; with a STATUS (#.03) of 'NO LONGER REQUIRED' in the Annual Means
+7 ; Test file (408.31). These were created due to the presence of a
+8 ; REQUIRED test which was primary for the current income year at the
+9 ; time the means test was uploaded.
+10 ;
+11 ; In addition, if there is a REQUIRED test present within 365 days of
+12 ; the means test under review which is primary then this is set to
+13 ; NON primary.
+14 ;
+15 ; Finally, the DG MEANS TEST DRIVER protocol is called.
+16 ;
+17 ;
+18 ; ^XTMP("DG-MTIY",MTIY) track number of records processed:
+19 ; ^XTMP("DG-MTERR") contains error messages returned from FM DBS calls:
+20 ; ^XTMP("DG-MTERR",file#,record#,field#,n)=error message
+21 ;
POST ;
+1 ; post-install set up checkpoints and tracking global...
+2 NEW %,I,X,X1,X2
+3 IF $DATA(XPDNM)
Begin DoDot:1
+4 ; checkpoints
+5 IF $$VERCP^XPDUTL("DGMTIDT")'>0
Begin DoDot:2
+6 SET %=$$NEWCP^XPDUTL("DGMTIDT","","-9999999")
End DoDot:2
+7 IF $$VERCP^XPDUTL("DGDFN")'>0
Begin DoDot:2
+8 SET %=$$NEWCP^XPDUTL("DGDFN","",0)
End DoDot:2
+9 ;
End DoDot:1
+10 ;
+11 ; initialize tracking global (see text above for description)...
+12 FOR I="MTIY","MTERR"
Begin DoDot:1
+13 IF $DATA(^XTMP(I))
QUIT
+14 SET X1=DT
+15 SET X2=30
+16 DO C^%DTC
+17 SET ^XTMP("DG-"_I,0)=X_"^"_$$DT^XLFDT_"^DG*5.3*285 POST-INSTALL "_$S(I="MTIY":"record count",1:"filing errors")
End DoDot:1
+18 ;
EN ; begin processing...
+1 NEW %
+2 ; check status and if root checkpoint has not completed start clean up
+3 IF $DATA(XPDNM)
SET %=$$VERCP^XPDUTL("DGMTIDT")
+4 IF $GET(%)=""
SET %=0
+5 IF %=0
DO EN1
+6 QUIT
+7 ;
EN1 ; begin purge...
+1 ; write message to installation device and to INSTALL file (#9.7)
+2 DO BMES^XPDUTL("POST INSTALLATION PROCESSING")
+3 DO MES^XPDUTL("Once the post-install is completed, a mail message will")
+4 DO MES^XPDUTL("be sent that will report the count of records, by income")
+5 DO MES^XPDUTL("year, from which means test entries were purged.")
+6 DO MES^XPDUTL("Additionally, the report will contain notes")
+7 DO MES^XPDUTL("about any errors encountered during the post-installation.")
+8 DO BMES^XPDUTL("Beginning purge process "_$$FMTE^XLFDT($$NOW^XLFDT))
+9 ;
+10 ; process control body
+11 NEW DGMTIDT,DGDFN,STA,YR,FILERR,MTIEN
+12 ;
+13 IF '$DATA(XPDNM)
SET DGMTIDT=-99999999
+14 IF $DATA(XPDNM)
SET DGMTIDT=$$PARCP^XPDUTL("DGMTIDT")
SET DGDFN=$$PARCP^XPDUTL("DGDFN")
+15 SET STA=$PIECE($$SITE^VASITE,"^",3)
+16 FOR
SET DGMTIDT=$ORDER(^DGMT(408.31,"AS",1,3,DGMTIDT))
if 'DGMTIDT!(DGMTIDT>-2980101)
QUIT
Begin DoDot:1
+17 if '$DATA(DGDFN)
SET DGDFN=0
+18 ; get current mean test year
SET YR=$EXTRACT(DGMTIDT,2,4)
+19 FOR
SET DGDFN=$ORDER(^DGMT(408.31,"AS",1,3,DGMTIDT,DGDFN))
if DGDFN=""
QUIT
Begin DoDot:2
+20 NEW FILERR
+21 ;
+22 ; get primary means test for this year
+23 SET NODE=$$LST^DGMTU(DGDFN,YR_"1231")
+24 ;
+25 ; - if primary means test has a STATUS of 'No Longer Required' and
+26 ; it has the same MEANS TEST DATE as the current test then delete
+27 ; all 'No Longer Required' tests for this date except the primary
+28 ; test.
+29 ; - otherwise, delete all 'No Longer Required' means test for this
+30 ; date except the last entry.
+31 IF $PIECE(NODE,U,4)="N"
IF ($PIECE(NODE,U,2)=-DGMTIDT)
SET MTIEN=+NODE
+32 IF '$TEST
SET MTIEN=$ORDER(^DGMT(408.31,"AS",1,3,DGMTIDT,DGDFN,""),-1)
+33 DO DELMT(DGMTIDT,DGDFN,MTIEN,.FILERR)
+34 ;
+35 ; If 'No Longer Required' test then change 'Required'
+36 ; primary test for next Means Test year to Non-Primary and update
+37 ; STATUS of means test for current date
+38 DO RQ2NPRM(-DGMTIDT,DGDFN,STA,YR,NODE,.FILERR)
+39 ;
+40 ; if error then update temporary store
+41 IF $GET(FILERR)
MERGE ^XTMP("DG-MTERR")=FILERR
+42 ; update check point with patient ID
+43 IF $DATA(XPDNM)
SET %=$$UPCP^XPDUTL("DGDFN",DGDFN)
End DoDot:2
+44 ; update check point with means test inverse date
+45 IF $DATA(XPDNM)
SET %=$$UPCP^XPDUTL("DGMTIDT",DGMTIDT)
End DoDot:1
+46 ;
+47 ; send mailman msg to user/HEC with results
+48 DO MAIL^DG53285M
+49 IF $DATA(XPDNM)
SET %=$$COMCP^XPDUTL("DGMTIDT")
+50 DO MES^XPDUTL(" >>purge process completed "_$$FMTE^XLFDT($$NOW^XLFDT))
+51 QUIT
+52 ;
DELMT(MTIDT,DFN,ENTR,ERRS) ;
+1 ; Input:
+2 ; MTIDT - Inverse Means Tets Date
+3 ; DFN - Patient identifier
+4 ; ENTR - Entry # to ignore
+5 ; ERRS - DBS file error {by reference}
+6 ;
+7 NEW IEN,ERR
+8 ;
+9 SET IEN=0
+10 FOR
SET IEN=$ORDER(^DGMT(408.31,"AS",1,3,MTIDT,DFN,IEN))
if IEN=""
QUIT
Begin DoDot:1
+11 if IEN=ENTR
QUIT
+12 IF '$$EN^IVMCMD(IEN)
SET ERRS(408.31,IEN,"ALL")="Unable to delete means test"
QUIT
+13 ; increment purged count for income year
+14 DO COUNT(MTIDT)
End DoDot:1
+15 QUIT
+16 ;
RQ2NPRM(IDT,DFN,STA,YR,NODE,ERRS) ; change Required test to NON primary
+1 ;
+2 ; Input:
+3 ; IDT - Means Test Date
+4 ; DFN - Patient identifier
+5 ; ERRS - DBS file error {by reference}
+6 ; STA - Station number
+7 ; YR - Means Test year
+8 ; NODE - Last Primary test prior to end of Means Test year (YR)
+9 ;
+10 NEW NODE1,NODE2,DATA,REC31,ERR,DGADDF,DGREQF
+11 ;
+12 ; get primary test for next year
+13 SET NODE1=$$LST^DGMTU(DFN,YR+1_"1231")
+14 ;
+15 ; 1. if there is no Primary test for the year in which the
+16 ; remaining 'No Longer Required' test began then make it
+17 ; primary.
+18 ; 2. if primary means test for for subsequent year is Required,
+19 ; is within 365 days of current means test date and this site
+20 ; conducted test then make primary means test NON primary.
+21 ; 3. if this site conducted test then change check if test
+22 ; is required. If it is required then the STATUS of the
+23 ; single remaining No Longer Required means test for this date
+24 ; will equal the value of the TEST-DETERMINED STATUS.
+25 ;
+26 ; (1) determine is 'No Longer Required' test should be primary
+27 SET REC31=$ORDER(^DGMT(408.31,"AS",1,3,-IDT,DFN,""))
+28 IF +REC31
IF (+$EXTRACT($PIECE(NODE,U,2),1,3)<$EXTRACT($PIECE(^DGMT(408.31,REC31,0),U),1,3))
Begin DoDot:1
+29 SET DATA(2)=1
+30 IF '$$UPD^DGENDBS(408.31,REC31,.DATA,.ERR)
if $DATA(ERR)
SET ERRS(408.31,REC31,2)=ERR
+31 End DoDot:1
+32 ; (2) determine if subsequent year test should be Non primary
+33 IF $PIECE(NODE1,U,2)>(YR_1231)
IF ($PIECE(NODE1,U,4)="R")
IF $$SCOPE($PIECE(NODE1,U,2),IDT)
Begin DoDot:1
+34 ; set REQUIRED test to NON primary
+35 SET DATA(2)=0
+36 IF '$$UPD^DGENDBS(408.31,+NODE1,.DATA,.ERR)
if $DATA(ERR)
SET ERRS(408.31,+NODE1,2)=ERR
QUIT
End DoDot:1
+37 ;
+38 ; (3) Check if remaining No Longer Required test for this date is
+39 ; Required
+40 if REC31=""
QUIT
+41 SET NODE2=$GET(^DGMT(408.31,REC31,2))
+42 if $PIECE(NODE2,U,5)'=STA
QUIT
+43 DO REQ(DFN,REC31,3,IDT)
+44 QUIT
+45 ;
SCOPE(X1,X2) ; Check if dates within 365 days of one another
+1 DO ^%DTC
+2 IF X>365
QUIT 0
+3 IF '$TEST
QUIT 1
+4 QUIT
+5 ;
COUNT(DATE) ; update process tracking mechanisms...
+1 ; Input:
+2 ; DATE = inverse date from "AS" x-ref in 408.31
+3 ;
+4 NEW %,IY
+5 SET IY=$EXTRACT(DATE,2,4)-1
+6 SET ^XTMP("DG-MTIY",IY)=+$GET(^XTMP("DG-MTIY",IY))+1
+7 QUIT
+8 ;
REQ(DFN,DGMTI,DGCS,IDT) ; Determine if test is Required
+1 ;
+2 ; ** amended copy of EN^DGMTR as check for latest Primary **
+3 ; ** test is not valid for this cleanup. **
+4 ;
+5 ; Input:
+6 ; DFN - Patient ID
+7 ; DGMTI - Annual Means Test IEN
+8 ; DGCS - Annual Means Test Status
+9 ; IDT - Means Test Date
+10 ;
+11 ; Output:
+12 ; DGREQF - Means Test Require Flag
+13 ; (1 if required and 0 if not required)
+14 ; DGDOM1 - DOM Patient Flag (defined and set to 1 if
+15 ; patient currently on a DOM ward)
+16 ;
+17 NEW DGDOM,DGMT0,DGMTYPT,OLD,DGRGAUTO,DGQSENT,DGMSGF
+18 ;
+19 SET (DGMSGF,DGQSENT,DGREQF)=0
SET (OLD,DGMTYPT)=1
+20 IF $DATA(^DPT(DFN,.36))
SET X=^(.36)
Begin DoDot:1
+21 IF $PIECE($GET(^DIC(8,+X,0)),"^",9)=5!($$SC^DGMTR(DFN))
SET DGREQF=1
+22 IF $PIECE(X,"^",2)
IF $PIECE(X,"^",2)<3
SET DGREQF=0
End DoDot:1
+23 IF DGREQF
if $GET(^DPT(DFN,.38))
SET DGREQF=0
+24 IF DGREQF
DO DOM^DGMTR
if $GET(DGDOM)
SET DGREQF=0
+25 SET DGMT0=$GET(^DGMT(408.31,DGMTI,0))
+26 IF DGCS
SET OLD=$$OLD^DGMTU4(IDT)
+27 ;
+28 Begin DoDot:1
+29 IF DGREQF
IF DGCS=3
IF 'OLD
DO REQ^DGMTR
QUIT
+30 IF DGREQF
IF '$GET(DGADDF)
IF (('DGCS)!(OLD))
DO ADD^DGMTR
QUIT
+31 IF 'DGREQF
IF DGCS
IF DGCS'=3
IF '$GET(DGDOM)
DO NOL^DGMTR
QUIT
End DoDot:1
+32 ;
+33 ;be sure to check whether or not patient is subject to RX copay!
+34 ;
+35 DO EN^DGMTCOR
+36 QUIT
