source: FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGPRSSN.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: 5.4 KB
Line 
1RGPRSSN ;WAS/FHM-MPI/PD PSEUDO/MISSING SSN REPORT ;6/25/98
2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**19,34**;30 Apr 99
3 ;
4 ;Reference to ^DIC(8 supported by IA #427
5 ;Reference to ^DGPM( supported by IA #966
6 ;Reference to ^SCE( supported by IA #2443
7 ;Reference to ADM^VADPT2 supported by IA #325
8 ;
9 ;EXTRACT BAD SSN AND SORTS THEM BY CLASSIFICATION
10 W !,"This report will provide a list of:"
11 W !,"(1) any B Cross-references (there is no 'zero' node but a B x-ref)"
12 W !," on the patient file,"
13 W !,"(2) patients with Pseudo SSNs who have not had activity within the past 3 years,"
14 W !,"(3) patients with Pseudo SSNs who have had activity within the past 3 years.",!
15 W !,"The Reports are sorted by Primary Eligibility Code. The report can"
16 W !,"be queued if desired."
17 W !,!,"For MPI/PD purposes, general advice is to concentrate first on"
18 W !,"getting correct SSNs for the patients who HAVE had activity within"
19 W !,"the past 3 years.",!
20 S %ZIS="QM" D ^%ZIS G EXIT:POP
21 K ^TMP($J)
22 I $D(IO("Q")) D Q
23 .S ZTRTN="DQ^RGPRSSN",ZTDESC="MPI/PD SSN VALIDATION"
24 .D ^%ZTLOAD D HOME^%ZIS K IO("Q")
25DQ N DTOUT,DUOUT S RGFS=1,PRNTCODE="",RGPRNTCO=""
26 U IO W @IOF,!,"MPI/PD Report of Pseudo, missing & potentially false SSNs "
27 D NOW^%DTC D YX^%DTC
28 W ?55,Y,!
29 W !,"Bad B Cross References Report"
30 W !,"Please contact IRM for assistance with bad B Cross references."
31 W !,"----------------------------------------------------------------------------"
32 S BREF=0
33 S NAME=""
34 F S NAME=$O(^DPT("B",NAME)) Q:NAME="" D
35 .S REFNO=0
36 .S REFNO=$O(^DPT("B",NAME,REFNO)) Q:REFNO=""
37 .IF $D(^DPT(REFNO,0)) S NODE=^DPT(REFNO,0),RGSSN=$P(NODE,"^",9)
38 .E S BREF=1 W !,"B Cross Reference with no 0 Node in DPT: DFN= ",REFNO Q
39 .IF RGSSN="" S RGSSN="None"
40 .IF RGSSN'?9N S SCRATCH=$$SETGBL
41 .IF RGSSN="123456789" S SCRATCH=$$SETGBL
42 .IF RGSSN="000000000" S SCRATCH=$$SETGBL
43 .IF RGSSN="111111111" S SCRATCH=$$SETGBL
44 .IF RGSSN="222222222" S SCRATCH=$$SETGBL
45 .IF RGSSN="333333333" S SCRATCH=$$SETGBL
46 .IF RGSSN="444444444" S SCRATCH=$$SETGBL
47 .IF RGSSN="555555555" S SCRATCH=$$SETGBL
48 .IF RGSSN="666666666" S SCRATCH=$$SETGBL
49 .IF RGSSN="777777777" S SCRATCH=$$SETGBL
50 .IF RGSSN="888888888" S SCRATCH=$$SETGBL
51 .IF RGSSN?1"9"8N S SCRATCH=$$SETGBL
52 .QUIT
53 IF BREF=0 W !,"*** No Bad B Cross References Found in your account.***"
54LST S (ACTIV1,ECODE1,NAME1,REFNO1)=""
55LST1 S ACTIV1=$O(^TMP($J,ACTIV1)) G EXIT:ACTIV1="" D HEADER G EXIT:$D(DUOUT)!($D(DTOUT))
56LST2 S ECODE1=$O(^TMP($J,ACTIV1,ECODE1)) G LST1:ECODE1="" D:$Y>(IOSL-4) HEADER,HEAD2 G:$D(DUOUT)!($D(DTOUT)) EXIT W ! S SCRATCH=$$GETECODE
57LST3 S NAME1=$O(^TMP($J,ACTIV1,ECODE1,NAME1)) G LST2:NAME1="" D:$Y>(IOSL-4) HEADER,HEAD2 G:$D(DUOUT)!($D(DTOUT)) EXIT
58 S REFNO1=^TMP($J,ACTIV1,ECODE1,NAME1)
59 S (PHONE,RGSSN,ECODE)="None"
60 ;Using VADPT for PHONE# , SSN ,eligibility code, and Name
61 K VAPTYP,VAHOW,VAROOT,VADM,VAEL,VAPA,VATEST S DFN=REFNO1 D ADD^VADPT,DEM^VADPT,ELIG^VADPT S NAME=VADM(1),RGSSN=$P(VADM(2),U),PHONE=VAPA(8),ECODE=$P(VAEL(1),U)
62 K VAPTYP,VAHOW,VAROOT,VADM,VAEL,VAPA,VATEST
63 S ACTIVITY=$$ACTIVE(REFNO1)
64 W !,?10,ECODE,?20,NAME1,?54,RGSSN,?65,PHONE
65 GOTO LST3
66EXIT D ^%ZISC
67 S:$D(ZTQUEUED) ZTREQ="@"
68 K ^TMP($J)
69 K ACTIV1,ACTIVITY,BREF,ECODE,ECODE1,NAME,NAME1,NODE,NODE2,NODE3
70 K NODE4,PHONE,PRNTCODE,REFNO,REFNO1,RGFS,RGPRNTCO,SCRATCH,RGSSN,ZTREQ,%ZIS,NODE1,POP,ZTDESC,ZTRTN
71 QUIT
72SETGBL() ;SETS GLOBAL
73 S ECODE=""
74 K VAEL S DFN=REFNO D ELIG^VADPT S ECODE=$P(VAEL(1),U)
75 IF ECODE="" S ECODE="None"
76 S ACTIVITY=$$ACTIVE(REFNO)
77 S ^TMP($J,ACTIVITY,ECODE,NAME)=REFNO
78 QUIT 1
79GETECODE() ;
80 S PRNTCODE="None"
81 IF $D(^DIC(8,ECODE1,0)) S NODE4=^DIC(8,ECODE1,0),PRNTCODE=$P(NODE4,"^",1)
82 W !,PRNTCODE S RGFS=0
83 QUIT 1
84LTD(DFN) ;
85 ;FIND LAST TREATMENT DATE
86 ;INPUT: DFN
87 ;OUTPUT: LTD LAST TREATMENT DATE
88 ;
89 ;
90 N LTD,X
91 ;
92 ; - NEED A PATIENT
93 I '$G(DFN) S LTD=0 G LTDQ
94 ;
95 ; - IF CURRENT INPATIENT, SET LTD = TODAY AND QUIT
96 ;Current admission movement from ADM^VAPDT2
97 K VADMVT,VAINDT D ADM^VADPT2 I $L(VADMVT) S LTD=DT K VADMVT,VAERR,VAINDT G LTDQ
98 K VADMVT,VAERR,VAINDT
99 ;
100 ; - GET THE LAST DISCHARGE DATE
101 S LTD=+$O(^DGPM("ATID3",DFN,"")) S:LTD LTD=9999999.9999999-LTD\1 S:LTD>DT LTD=DT
102 ;
103 ; - GET THE LAST REGISTRATION DATE AND COMPARE IT TO LTD
104 K VAROOT,VARP,^UTILITY("VARP",$J) S VARP("F")=2000101 D REG^VADPT I $D(^UTILITY("VARP",$J,1,"I")) S X=$P(^("I"),U) I X S X=X\1 S:X>LTD LTD=X
105 K ^UTILITY("VARP",$J),VARP,VAERR
106 ;
107 ; - GET THE LAST STOP AND COMPARE TO LTD
108 ; Look at Outpatient Encounter, ^SDV is going away
109 ; Use an API instead of ordering through global
110 N OPIEN S OPIEN=$$GETLAST^SDOE(DFN,2000101,"C")
111 I $G(^SCE(+OPIEN,0)) S LTD=$P(^SCE(OPIEN,0),"^",1)\1
112 ;
113LTDQ ;
114 Q $S(LTD:LTD,1:0)
115 ;
116ACTIVE(DFN) ;
117 N LTD,TODAY,DIFF
118 S LTD=$$LTD(DFN)
119 Q:LTD'>0 "NO"
120 Q:$L(LTD)'=7 1_"^"_LTD_"^"_"ZERO"
121 S TODAY=$$NOW^XLFDT\1
122 S DIFF=$$FMDIFF^XLFDT(TODAY,LTD)
123 ; if difference is > 1096 days or 3 years
124 I DIFF>1096 Q "NO"
125 Q "YES"
126HEADER ;PRINT REPORT HEADER
127 I ($E(IOST,1,2)="C-")&(IO=IO(0)) D
128 . S DIR(0)="E"
129 . D ^DIR K DIR
130 Q:$D(DUOUT)!($D(DTOUT))
131 ;;;W:$D(IOF) @IOF
132 W @IOF,!,"MPI/PD Report of Pseudo, missing & potentially false SSNs "
133 D NOW^%DTC D YX^%DTC
134 W ?55,Y,! K Y
135 W !,?20,"Patient activity within past 3 years = ",$G(ACTIV1)
136 W !,?1,"Primary"
137 W !,?1,"Elig Code"
138 W !,?10,"Elig.",?20,"Name",?54,"SSN",?65,"Home Phone"
139 W !,"-----------------------------------------------------------------------------"
140 Q
141HEAD2 ;SUB HEADER
142 Q:$D(DUOUT)!($D(DTOUT))
143 I RGFS=0,PRNTCODE=RGPRNTCO W !,PRNTCODE
144 E I RGFS=0 W !,PRNTCODE S RGPRNTCO=PRNTCODE
145 Q
Note: See TracBrowser for help on using the repository browser.