EASXRPT1 ;ALB/AEG - Duplicate Pt. Relation Report ; 7-12-02
;;1.0;ENROLLMENT APPLICATION SYSTEM;**10**;Mar 15,2001
;
PRINT ; Output to selected I/O device.
U IO
N USER,RUN,A,B,C,HDR,PG,IY
K DIR,DIRUT
S USER=$$GET1^DIQ(200,DUZ_",",.01,"E")
S FSTP=1
S RUN="Run Date "_$$FMTE^XLFDT($E($$NOW^XLFDT,1,14),"1P")_" by "_USER
S HDR(4)="Duplicate PATIENT RELATION file Entries"
S HDR(5)="** Includes duplicates for both dependent and patient entries"
F A=1,2 D Q:$D(DIRUT)
.S HDR(1)=$S(A=2:"DECEASED PATIENT, NO ACTION REQUIRED",1:"ACTIVE DUPLICATE ENTRIES")
.F B=1,2 D Q:$D(DIRUT)
..S HDR(2)=$S(B=2:"Non Category C",1:"Category C")
..F C=1,2 D Q:$D(DIRUT)
...S HDR(3)=$S(C=2:"CMOR",1:"NON-CMOR")
...S PG=0
...D HDR,LOOP
...Q
..Q
.Q
D ^%ZISC
Q
;
HDR ; Report Header
N IX
S PG=PG+1,HDR(6)="PAGE "_PG
I '+$G(FSTP) W @IOF
W !,DAL
W !,RUN,!
F IX=1,2,3,4 W !?((IOM-$L(HDR(IX)))\2),HDR(IX)
W !
W !,?((IOM-3)-$L(HDR(5)))\2,HDR(5),?((IOM-1)-$L(HDR(6))),HDR(6)
W !,EQL
W !,"* - Represents entries without an SSN in the INCOME PERSON file (#408.13)"
W !,?4,"These entries must be corrected using the Edit an Existing Means Test",!,?4,"Option before merging or deleting."
I HDR(1)["Deceased" W !!,"NOTE: Corrective action does not apply to deceased duplicates."
W !!?(COL3),"408.12"
W !,"SSN",?COL2,"NAME",?(COL3+2),"IEN",?COL4,"DOB",?COL5,"ACT",?COL6,"EFF DATE",?COL7,"TYPE"
W !,$E(DAL,1,9),?COL2,$E(DAL,1,25),?COL3,$E(DAL,1,7),?COL4,$E(DAL,1,8),?COL5,$E(DAL,1,3),?COL6,$E(DAL,1,8),?COL7,$E(DAL,1,5)
S FSTP=0
Q
;
LOOP ; Loop thru data and provide output for report.
N DATA,IEN,FILE,DNODE,PNAME,SEX,DOB,SSN,NODE2,EASACT,TTYPE,EDATE
S DFN=0
I '$O(@ROOT(A,B,C)@(DFN)) D Q
.W !!,"NO DUPLICATE ENTRIES FOUND"
.I $E(IOST,1,2)="C-" D PAUSE^EASXDRUT Q:$D(DIRUT)
.Q
F S DFN=$O(@ROOT(A,B,C)@(DFN)) Q:DFN'>0 D Q:$D(DIRUT)
.S EASREL=""
.W !!,"VETERAN: "_$S($$GET1^DIQ(2,DFN_",",.01,"E")]"":$$GET1^DIQ(2,DFN_",",.01,"E"),1:"UNKNOWN")_" - "_$S($$GET1^DIQ(2,DFN_",",.09,"E")]"":$$GET1^DIQ(2,DFN_",",.09,"E"),1:"UNKNOWN SSN")
.F S EASREL=$O(@ROOT(A,B,C)@(DFN,EASREL)) Q:EASREL']"" D Q:$D(DIRUT)
..S EASCNT=0
..F S EASCNT=$O(@ROOT(A,B,C)@(DFN,EASREL,EASCNT)) Q:EASCNT'>0 D Q:$D(DIRUT)
...S DATA=$G(@ROOT(A,B,C)@(DFN,EASREL,EASCNT))
...S IEN=$P(DATA,U)
...S FILE=$P($$GET1^DIQ(408.12,IEN_",",.03,"I"),";",2)_$P($$GET1^DIQ(408.12,IEN_",",.03,"I"),";")
...S DNODE=$G(@("^"_FILE_",0)"))
...S PNAME=$P(DNODE,U),PNAME=$E(PNAME,1,25)
...S SEX=$P(DNODE,U,2),DOB=$$FMTE^XLFDT($P(DNODE,U,3),"2P")
...S SSN=$P(DNODE,U,9)
...I SSN']"" S SSN=$$GET1^DIQ(2,DFN_",",.09,"E")_"*"
...S NODE2=$G(^DGPR(408.12,+$P(DATA,U),"E",+$P($P(DATA,U,3),"~",3),0))
...S EASACT=$P(DATA,U,3)
...S TTYPE=$P(EASACT,"~",3)
...S TTYPE=$S(TTYPE]"":$$GET1^DIQ(408.33,TTYPE_",",.01,"E"),1:"UNK")
...S TTYPE=$P(TTYPE," ",1)
...S EASACT=$P(EASACT,"~")
...S EDATE=$$FMTE^XLFDT($P($P(NODE2,U),"."),"2P")
...W !,SSN,?COL2,PNAME,?COL3,$J(IEN,7),?COL4,$J(DOB,8),?COL5,$J($S(EASACT=1:"YES",EASACT=0:"NO",1:EASACT),3),?COL6,$J(EDATE,8),?COL7,TTYPE
...I $Y'<(IOSL-3) D PAUSE^EASXDRUT Q:$D(DIRUT) D HDR
Q:$D(DIRUT)
F IY=$Y:1:(IOSL-4) W !
I $E(IOST,1,2)="C-" D
.K DIR,DIRUT
.S DIR(0)="E"
.D ^DIR
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASXRPT1 3288 printed Nov 22, 2024@17:06:04 Page 2
EASXRPT1 ;ALB/AEG - Duplicate Pt. Relation Report ; 7-12-02
+1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**10**;Mar 15,2001
+2 ;
PRINT ; Output to selected I/O device.
+1 USE IO
+2 NEW USER,RUN,A,B,C,HDR,PG,IY
+3 KILL DIR,DIRUT
+4 SET USER=$$GET1^DIQ(200,DUZ_",",.01,"E")
+5 SET FSTP=1
+6 SET RUN="Run Date "_$$FMTE^XLFDT($EXTRACT($$NOW^XLFDT,1,14),"1P")_" by "_USER
+7 SET HDR(4)="Duplicate PATIENT RELATION file Entries"
+8 SET HDR(5)="** Includes duplicates for both dependent and patient entries"
+9 FOR A=1,2
Begin DoDot:1
+10 SET HDR(1)=$SELECT(A=2:"DECEASED PATIENT, NO ACTION REQUIRED",1:"ACTIVE DUPLICATE ENTRIES")
+11 FOR B=1,2
Begin DoDot:2
+12 SET HDR(2)=$SELECT(B=2:"Non Category C",1:"Category C")
+13 FOR C=1,2
Begin DoDot:3
+14 SET HDR(3)=$SELECT(C=2:"CMOR",1:"NON-CMOR")
+15 SET PG=0
+16 DO HDR
DO LOOP
+17 QUIT
End DoDot:3
if $DATA(DIRUT)
QUIT
+18 QUIT
End DoDot:2
if $DATA(DIRUT)
QUIT
+19 QUIT
End DoDot:1
if $DATA(DIRUT)
QUIT
+20 DO ^%ZISC
+21 QUIT
+22 ;
HDR ; Report Header
+1 NEW IX
+2 SET PG=PG+1
SET HDR(6)="PAGE "_PG
+3 IF '+$GET(FSTP)
WRITE @IOF
+4 WRITE !,DAL
+5 WRITE !,RUN,!
+6 FOR IX=1,2,3,4
WRITE !?((IOM-$LENGTH(HDR(IX)))\2),HDR(IX)
+7 WRITE !
+8 WRITE !,?((IOM-3)-$LENGTH(HDR(5)))\2,HDR(5),?((IOM-1)-$LENGTH(HDR(6))),HDR(6)
+9 WRITE !,EQL
+10 WRITE !,"* - Represents entries without an SSN in the INCOME PERSON file (#408.13)"
+11 WRITE !,?4,"These entries must be corrected using the Edit an Existing Means Test",!,?4,"Option before merging or deleting."
+12 IF HDR(1)["Deceased"
WRITE !!,"NOTE: Corrective action does not apply to deceased duplicates."
+13 WRITE !!?(COL3),"408.12"
+14 WRITE !,"SSN",?COL2,"NAME",?(COL3+2),"IEN",?COL4,"DOB",?COL5,"ACT",?COL6,"EFF DATE",?COL7,"TYPE"
+15 WRITE !,$EXTRACT(DAL,1,9),?COL2,$EXTRACT(DAL,1,25),?COL3,$EXTRACT(DAL,1,7),?COL4,$EXTRACT(DAL,1,8),?COL5,$EXTRACT(DAL,1,3),?COL6,$EXTRACT(DAL,1,8),?COL7,$EXTRACT(DAL,1,5)
+16 SET FSTP=0
+17 QUIT
+18 ;
LOOP ; Loop thru data and provide output for report.
+1 NEW DATA,IEN,FILE,DNODE,PNAME,SEX,DOB,SSN,NODE2,EASACT,TTYPE,EDATE
+2 SET DFN=0
+3 IF '$ORDER(@ROOT(A,B,C)@(DFN))
Begin DoDot:1
+4 WRITE !!,"NO DUPLICATE ENTRIES FOUND"
+5 IF $EXTRACT(IOST,1,2)="C-"
DO PAUSE^EASXDRUT
if $DATA(DIRUT)
QUIT
+6 QUIT
End DoDot:1
QUIT
+7 FOR
SET DFN=$ORDER(@ROOT(A,B,C)@(DFN))
if DFN'>0
QUIT
Begin DoDot:1
+8 SET EASREL=""
+9 WRITE !!,"VETERAN: "_$SELECT($$GET1^DIQ(2,DFN_",",.01,"E")]"":$$GET1^DIQ(2,DFN_",",.01,"E"),1:"UNKNOWN")_" - "_$SELECT($$GET1^DIQ(2,DFN_",",.09,"E")]"":$$GET1^DIQ(2,DFN_",",.09,"E"),1:"UNKNOWN SSN")
+10 FOR
SET EASREL=$ORDER(@ROOT(A,B,C)@(DFN,EASREL))
if EASREL']""
QUIT
Begin DoDot:2
+11 SET EASCNT=0
+12 FOR
SET EASCNT=$ORDER(@ROOT(A,B,C)@(DFN,EASREL,EASCNT))
if EASCNT'>0
QUIT
Begin DoDot:3
+13 SET DATA=$GET(@ROOT(A,B,C)@(DFN,EASREL,EASCNT))
+14 SET IEN=$PIECE(DATA,U)
+15 SET FILE=$PIECE($$GET1^DIQ(408.12,IEN_",",.03,"I"),";",2)_$PIECE($$GET1^DIQ(408.12,IEN_",",.03,"I"),";")
+16 SET DNODE=$GET(@("^"_FILE_",0)"))
+17 SET PNAME=$PIECE(DNODE,U)
SET PNAME=$EXTRACT(PNAME,1,25)
+18 SET SEX=$PIECE(DNODE,U,2)
SET DOB=$$FMTE^XLFDT($PIECE(DNODE,U,3),"2P")
+19 SET SSN=$PIECE(DNODE,U,9)
+20 IF SSN']""
SET SSN=$$GET1^DIQ(2,DFN_",",.09,"E")_"*"
+21 SET NODE2=$GET(^DGPR(408.12,+$PIECE(DATA,U),"E",+$PIECE($PIECE(DATA,U,3),"~",3),0))
+22 SET EASACT=$PIECE(DATA,U,3)
+23 SET TTYPE=$PIECE(EASACT,"~",3)
+24 SET TTYPE=$SELECT(TTYPE]"":$$GET1^DIQ(408.33,TTYPE_",",.01,"E"),1:"UNK")
+25 SET TTYPE=$PIECE(TTYPE," ",1)
+26 SET EASACT=$PIECE(EASACT,"~")
+27 SET EDATE=$$FMTE^XLFDT($PIECE($PIECE(NODE2,U),"."),"2P")
+28 WRITE !,SSN,?COL2,PNAME,?COL3,$JUSTIFY(IEN,7),?COL4,$JUSTIFY(DOB,8),?COL5,$JUSTIFY($SELECT(EASACT=1:"YES",EASACT=0:"NO",1:EASACT),3),?COL6,$JUSTIFY(EDATE,8),?COL7,TTYPE
+29 IF $Y'<(IOSL-3)
DO PAUSE^EASXDRUT
if $DATA(DIRUT)
QUIT
DO HDR
End DoDot:3
if $DATA(DIRUT)
QUIT
End DoDot:2
if $DATA(DIRUT)
QUIT
End DoDot:1
if $DATA(DIRUT)
QUIT
+30 if $DATA(DIRUT)
QUIT
+31 FOR IY=$Y:1:(IOSL-4)
WRITE !
+32 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+33 KILL DIR,DIRUT
+34 SET DIR(0)="E"
+35 DO ^DIR
End DoDot:1
+36 QUIT
+37 ;
