source: FOIAVistA/trunk/r/ENROLLMENT_APPLICATION_SYSTEM-EAS/EASXRPT1.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.1 KB
Line 
1EASXRPT1 ;ALB/AEG - Duplicate Pt. Relation Report ; 7-12-02
2 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**10**;Mar 15,2001
3 ;
4PRINT ; Output to selected I/O device.
5 U IO
6 N USER,RUN,A,B,C,HDR,PG,IY
7 K DIR,DIRUT
8 S USER=$$GET1^DIQ(200,DUZ_",",.01,"E")
9 S FSTP=1
10 S RUN="Run Date "_$$FMTE^XLFDT($E($$NOW^XLFDT,1,14),"1P")_" by "_USER
11 S HDR(4)="Duplicate PATIENT RELATION file Entries"
12 S HDR(5)="** Includes duplicates for both dependent and patient entries"
13 F A=1,2 D Q:$D(DIRUT)
14 .S HDR(1)=$S(A=2:"DECEASED PATIENT, NO ACTION REQUIRED",1:"ACTIVE DUPLICATE ENTRIES")
15 .F B=1,2 D Q:$D(DIRUT)
16 ..S HDR(2)=$S(B=2:"Non Category C",1:"Category C")
17 ..F C=1,2 D Q:$D(DIRUT)
18 ...S HDR(3)=$S(C=2:"CMOR",1:"NON-CMOR")
19 ...S PG=0
20 ...D HDR,LOOP
21 ...Q
22 ..Q
23 .Q
24 D ^%ZISC
25 Q
26 ;
27HDR ; Report Header
28 N IX
29 S PG=PG+1,HDR(6)="PAGE "_PG
30 I '+$G(FSTP) W @IOF
31 W !,DAL
32 W !,RUN,!
33 F IX=1,2,3,4 W !?((IOM-$L(HDR(IX)))\2),HDR(IX)
34 W !
35 W !,?((IOM-3)-$L(HDR(5)))\2,HDR(5),?((IOM-1)-$L(HDR(6))),HDR(6)
36 W !,EQL
37 W !,"* - Represents entries without an SSN in the INCOME PERSON file (#408.13)"
38 W !,?4,"These entries must be corrected using the Edit an Existing Means Test",!,?4,"Option before merging or deleting."
39 I HDR(1)["Deceased" W !!,"NOTE: Corrective action does not apply to deceased duplicates."
40 W !!?(COL3),"408.12"
41 W !,"SSN",?COL2,"NAME",?(COL3+2),"IEN",?COL4,"DOB",?COL5,"ACT",?COL6,"EFF DATE",?COL7,"TYPE"
42 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)
43 S FSTP=0
44 Q
45 ;
46LOOP ; Loop thru data and provide output for report.
47 N DATA,IEN,FILE,DNODE,PNAME,SEX,DOB,SSN,NODE2,EASACT,TTYPE,EDATE
48 S DFN=0
49 I '$O(@ROOT(A,B,C)@(DFN)) D Q
50 .W !!,"NO DUPLICATE ENTRIES FOUND"
51 .I $E(IOST,1,2)="C-" D PAUSE^EASXDRUT Q:$D(DIRUT)
52 .Q
53 F S DFN=$O(@ROOT(A,B,C)@(DFN)) Q:DFN'>0 D Q:$D(DIRUT)
54 .S EASREL=""
55 .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")
56 .F S EASREL=$O(@ROOT(A,B,C)@(DFN,EASREL)) Q:EASREL']"" D Q:$D(DIRUT)
57 ..S EASCNT=0
58 ..F S EASCNT=$O(@ROOT(A,B,C)@(DFN,EASREL,EASCNT)) Q:EASCNT'>0 D Q:$D(DIRUT)
59 ...S DATA=$G(@ROOT(A,B,C)@(DFN,EASREL,EASCNT))
60 ...S IEN=$P(DATA,U)
61 ...S FILE=$P($$GET1^DIQ(408.12,IEN_",",.03,"I"),";",2)_$P($$GET1^DIQ(408.12,IEN_",",.03,"I"),";")
62 ...S DNODE=$G(@("^"_FILE_",0)"))
63 ...S PNAME=$P(DNODE,U),PNAME=$E(PNAME,1,25)
64 ...S SEX=$P(DNODE,U,2),DOB=$$FMTE^XLFDT($P(DNODE,U,3),"2P")
65 ...S SSN=$P(DNODE,U,9)
66 ...I SSN']"" S SSN=$$GET1^DIQ(2,DFN_",",.09,"E")_"*"
67 ...S NODE2=$G(^DGPR(408.12,+$P(DATA,U),"E",+$P($P(DATA,U,3),"~",3),0))
68 ...S EASACT=$P(DATA,U,3)
69 ...S TTYPE=$P(EASACT,"~",3)
70 ...S TTYPE=$S(TTYPE]"":$$GET1^DIQ(408.33,TTYPE_",",.01,"E"),1:"UNK")
71 ...S TTYPE=$P(TTYPE," ",1)
72 ...S EASACT=$P(EASACT,"~")
73 ...S EDATE=$$FMTE^XLFDT($P($P(NODE2,U),"."),"2P")
74 ...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
75 ...I $Y'<(IOSL-3) D PAUSE^EASXDRUT Q:$D(DIRUT) D HDR
76 Q:$D(DIRUT)
77 F IY=$Y:1:(IOSL-4) W !
78 I $E(IOST,1,2)="C-" D
79 .K DIR,DIRUT
80 .S DIR(0)="E"
81 .D ^DIR
82 Q
83 ;
Note: See TracBrowser for help on using the repository browser.