DG53294A ;ALB/RTK - Means Test Utilities ;10/20/00
;;5.3;Registration;**294**;Aug 13, 1993
;
;This routine will edit the newly added ELIGIBILITY VERIF.
;SOURCE (.3613) field of the PATIENT (#2) file to populate it
;for use with new logic that is being implemented as part of
;the Ineligible project. The source will be set as follows:
;
;If the ELIGIBILITY VERIF. METHOD (.3615) is VIVA, and the
;entity verifying (.3616) is POSTMASTER, the source field
;will be set to HEC.
;
;All other patient records with an existing eligibility node
;(.361) will be set to HEC.
;
EN N DATA,LFDATE,DFN,I,X,X1,X2,%
S (ERRMSG,FILERR)=""
I $D(XPDNM) D
.I $$VERCP^XPDUTL("LFDATE")'>0 D
..S %=$$NEWCP^XPDUTL("LFDATE","","0")
.I $$VERCP^XPDUTL("DFN")'>0 D
..S %=$$NEWCP^XPDUTL("DFN","","0")
;
F I="SRCREC","SRCSET","SRCERR" D
.I $D(^XTMP("DG-"_I)) Q
.S X1=DT
.S X2=30
.D C^%DTC
.S ^XTMP("DG-"_I,0)=X_"^"_$$DT^XLFDT_"^DG*5.3*294 POST-INSTALL "_$S(I="SRCREC":"record count",I="SRCSET":"records corrected",1:"filing errors")
;
I '$D(XPDNM) S (^XTMP("DG-SRCREC",1),^XTMP("DG-SRCSET",1))=0
I $D(XPDNM)&'$D(^XTMP("DG-SRCREC",1)) S ^XTMP("DG-SRCREC",1)=0
I $D(XPDNM)&'$D(^XTMP("DG-SRCSET",1)) S ^XTMP("DG-SRCSET",1)=0
I $D(XPDNM) S %=$$VERCP^XPDUTL("LFDATE")
I $G(%)="" S %=0
I %=0 D EN1
Q
EN1 I '$D(XPDNM) S LFDATE=""
I $D(XPDNM) S LFDATE=$$PARCP^XPDUTL("LFDATE")
S DFN="",RECSET=0
F S LFDATE=$O(^DPT("B",LFDATE)) Q:LFDATE="" D
.F S DFN=$O(^DPT("B",LFDATE,DFN)) Q:DFN="" D
..I '$D(^DPT(DFN,0)) S FILERR(2,DFN,"ALL")="Patient record "_DFN_" does not exist." M ^XTMP("DG-SRCERR")=FILERR K FILERR Q
..I $D(^DPT(DFN,.361)) D
...S ^XTMP("DG-SRCREC",1)=$G(^XTMP("DG-SRCREC",1))+1
...I $P(^DPT(DFN,.361),U,5)["VIVA",($P(^DPT(DFN,.361),U,6)=.5) D
....S DATA(.3613)="H",RECSET=1 I $$UPD^DGENDBS(2,DFN,.DATA) S ^XTMP("DG-SRCSET",1)=$G(^XTMP("DG-SRCSET",1))+1
...I $P(^DPT(DFN,.361),U,5)'["VIVA"!($P(^DPT(DFN,.361),U,6)'=.5) D
....S DATA(.3613)="V",RECSET=1 I $$UPD^DGENDBS(2,DFN,.DATA) S ^XTMP("DG-SRCSET",1)=$G(^XTMP("DG-SRCSET",1))+1
...I 'RECSET S FILERR(2,DFN,"ALL")="Unable to edit patient record "_DFN_"." Q
...S RECSET=0
..I $G(FILERR) M ^XTMP("DG-SRCERR")=FILERR K FILERR
..I $D(XPDNM) S %=$$UPCP^XPDUTL("DFN",DFN)
.I $D(XPDNM) S %=$$UPCP^XPDUTL("LFDATE",LFDATE)
D MAIL^DG53294M
I $D(XPDNM) S %=$$COMCP^XPDUTL("LFDATE")
D BMES^XPDUTL(" ELIGIBILITY VERIF. SOURCE edit process is complete.")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53294A 2493 printed Dec 13, 2024@02:37:03 Page 2
DG53294A ;ALB/RTK - Means Test Utilities ;10/20/00
+1 ;;5.3;Registration;**294**;Aug 13, 1993
+2 ;
+3 ;This routine will edit the newly added ELIGIBILITY VERIF.
+4 ;SOURCE (.3613) field of the PATIENT (#2) file to populate it
+5 ;for use with new logic that is being implemented as part of
+6 ;the Ineligible project. The source will be set as follows:
+7 ;
+8 ;If the ELIGIBILITY VERIF. METHOD (.3615) is VIVA, and the
+9 ;entity verifying (.3616) is POSTMASTER, the source field
+10 ;will be set to HEC.
+11 ;
+12 ;All other patient records with an existing eligibility node
+13 ;(.361) will be set to HEC.
+14 ;
EN NEW DATA,LFDATE,DFN,I,X,X1,X2,%
+1 SET (ERRMSG,FILERR)=""
+2 IF $DATA(XPDNM)
Begin DoDot:1
+3 IF $$VERCP^XPDUTL("LFDATE")'>0
Begin DoDot:2
+4 SET %=$$NEWCP^XPDUTL("LFDATE","","0")
End DoDot:2
+5 IF $$VERCP^XPDUTL("DFN")'>0
Begin DoDot:2
+6 SET %=$$NEWCP^XPDUTL("DFN","","0")
End DoDot:2
End DoDot:1
+7 ;
+8 FOR I="SRCREC","SRCSET","SRCERR"
Begin DoDot:1
+9 IF $DATA(^XTMP("DG-"_I))
QUIT
+10 SET X1=DT
+11 SET X2=30
+12 DO C^%DTC
+13 SET ^XTMP("DG-"_I,0)=X_"^"_$$DT^XLFDT_"^DG*5.3*294 POST-INSTALL "_$S(I="SRCREC":"record count",I="SRCSET":"records corrected",1:"filing errors")
End DoDot:1
+14 ;
+15 IF '$DATA(XPDNM)
SET (^XTMP("DG-SRCREC",1),^XTMP("DG-SRCSET",1))=0
+16 IF $DATA(XPDNM)&'$DATA(^XTMP("DG-SRCREC",1))
SET ^XTMP("DG-SRCREC",1)=0
+17 IF $DATA(XPDNM)&'$DATA(^XTMP("DG-SRCSET",1))
SET ^XTMP("DG-SRCSET",1)=0
+18 IF $DATA(XPDNM)
SET %=$$VERCP^XPDUTL("LFDATE")
+19 IF $GET(%)=""
SET %=0
+20 IF %=0
DO EN1
+21 QUIT
EN1 IF '$DATA(XPDNM)
SET LFDATE=""
+1 IF $DATA(XPDNM)
SET LFDATE=$$PARCP^XPDUTL("LFDATE")
+2 SET DFN=""
SET RECSET=0
+3 FOR
SET LFDATE=$ORDER(^DPT("B",LFDATE))
if LFDATE=""
QUIT
Begin DoDot:1
+4 FOR
SET DFN=$ORDER(^DPT("B",LFDATE,DFN))
if DFN=""
QUIT
Begin DoDot:2
+5 IF '$DATA(^DPT(DFN,0))
SET FILERR(2,DFN,"ALL")="Patient record "_DFN_" does not exist."
MERGE ^XTMP("DG-SRCERR")=FILERR
KILL FILERR
QUIT
+6 IF $DATA(^DPT(DFN,.361))
Begin DoDot:3
+7 SET ^XTMP("DG-SRCREC",1)=$GET(^XTMP("DG-SRCREC",1))+1
+8 IF $PIECE(^DPT(DFN,.361),U,5)["VIVA"
IF ($PIECE(^DPT(DFN,.361),U,6)=.5)
Begin DoDot:4
+9 SET DATA(.3613)="H"
SET RECSET=1
IF $$UPD^DGENDBS(2,DFN,.DATA)
SET ^XTMP("DG-SRCSET",1)=$GET(^XTMP("DG-SRCSET",1))+1
End DoDot:4
+10 IF $PIECE(^DPT(DFN,.361),U,5)'["VIVA"!($PIECE(^DPT(DFN,.361),U,6)'=.5)
Begin DoDot:4
+11 SET DATA(.3613)="V"
SET RECSET=1
IF $$UPD^DGENDBS(2,DFN,.DATA)
SET ^XTMP("DG-SRCSET",1)=$GET(^XTMP("DG-SRCSET",1))+1
End DoDot:4
+12 IF 'RECSET
SET FILERR(2,DFN,"ALL")="Unable to edit patient record "_DFN_"."
QUIT
+13 SET RECSET=0
End DoDot:3
+14 IF $GET(FILERR)
MERGE ^XTMP("DG-SRCERR")=FILERR
KILL FILERR
+15 IF $DATA(XPDNM)
SET %=$$UPCP^XPDUTL("DFN",DFN)
End DoDot:2
+16 IF $DATA(XPDNM)
SET %=$$UPCP^XPDUTL("LFDATE",LFDATE)
End DoDot:1
+17 DO MAIL^DG53294M
+18 IF $DATA(XPDNM)
SET %=$$COMCP^XPDUTL("LFDATE")
+19 DO BMES^XPDUTL(" ELIGIBILITY VERIF. SOURCE edit process is complete.")
+20 QUIT
