source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGYMF31A.m@ 1093

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

initial load of FOIAVistA 6/30/08 version

File size: 3.5 KB
Line 
1DGYMF31A ;ALB/CMM FIND DANGLING PT IN ^DPT TO ^DIC(31 ;12/30/94
2 ;;5.3;Registration;**53**;Aug 13, 1993
3 ;
4 ;This is a one shot routine that will loop through the patient
5 ;file entries looking at the disabilities to see if the pointer
6 ;values are valid to file 31 (disability conditions file).
7 ;
8DRIVE ;
9 U IO S PAGE=1
10 D LOOP
11 S ^TMP($J,"DG31",0)=NXT,INDEX="B"
12 D HEAD1 I $O(^TMP($J,"DG31",0))="" W !!,"No bad pointers." Q
13 D REPORT I END="Y" Q
14 I $D(^TMP($J,"DG31","D")) S INDEX="D" D HEAD I END'="Y" D REPORT
15 I END'="Y" W !!,"TOTAL PATIENTS WITH DANGLING POINTER(S) = ",NXT
16 I $D(ZTSK) D EXIT^DGYMF31
17 Q
18LOOP ;looping through patient file
19 S (DFN,NXT,CPT)=0 K ^TMP($J,"DG31")
20 F S DFN=$O(^DPT(DFN)) Q:'DFN D
21 .S (ANY,CNT)=0,CPT=CPT+1
22 .I $E(IOST,1,2)="C-" W:'(CPT#100) "."
23 .F S CNT=$O(^DPT(DFN,.372,CNT)) Q:CNT="" D
24 ..S PTR=+^DPT(DFN,.372,CNT,0)
25 ..I '$D(^DIC(31,PTR,0)) D:BADDEL="Y" KILL S ANY=ANY+1 I ANY D FOUND
26 .I ANY&(INVALID="Y") D DIS
27 Q
28FOUND ;
29 S LAST=$$LTD(DFN)
30 S DEAD=+$G(^DPT(DFN,.35))
31 I '$D(^TMP($J,"DG31",$S('DEAD:"B",1:"D"),$P(^DPT(DFN,0),"^"))) D
32 .S NXT=NXT+1,^TMP($J,"DG31",NXT)=$P(^DPT(DFN,0),"^")_"^"_$P(^DPT(DFN,0),"^",9)_"^"_$P(^DPT(DFN,0),"^",3)_"^"_LAST_"^"_DEAD
33 .S ^TMP($J,"DG31",$S('DEAD:"B",1:"D"),$P(^DPT(DFN,0),"^"),NXT)=""
34 Q
35DIS ;include 'good' disabilities in report
36 N PTR,TLP,TCT S (TLP,TCT)=0
37 F S TLP=$O(^DPT(DFN,.372,TLP)) Q:TLP="" D
38 .S PTR=+^DPT(DFN,.372,TLP,0)
39 .I $D(^DIC(31,PTR,0)) S TCT=TCT+1,^TMP($J,"DG31",NXT,TCT)=$P(^DIC(31,PTR,0),"^")
40 Q
41HEAD ;
42 S END="N"
43 I ($E(IOST,1,2)="C-") S DIR(0)="E" D ^DIR I 'Y S END="Y" K X,Y,DUOUT,DTOUT,DIRUT Q
44HEAD1 ;
45 W @IOF
46 W !!,"Patients with bad pointers in the Rated Disability field ",?100,"PAGE ",PAGE,!
47 W !,?5,"Patient Name",?35,"SSN",?50,"Date of Birth",?70,"Last Date of Contact"
48 I INDEX="D" W ?100,"Date of Death"
49 I INVALID="Y" W !,?10,"Valid Disabilities on file"
50 W !
51 S PAGE=PAGE+1
52 Q
53REPORT ;Display information gathered.
54 N NM S LP=0,END="N",NM=""
55 F S NM=$O(^TMP($J,"DG31",INDEX,NM)) Q:(NM="")!(END="Y") D
56 .F S LP=$O(^TMP($J,"DG31",INDEX,NM,LP)) Q:(LP="")!(END="Y") D
57 ..I $Y+3>IOSL D HEAD I END="Y" Q
58 ..D DATA
59 ..I INVALID="Y" D DATA2
60 Q
61DATA ;
62 N NODE S NODE=^TMP($J,"DG31",LP)
63 S SSN=$P(NODE,"^",2),SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)
64 S DEAD=$$FMTE^XLFDT($P(NODE,"^",5)) I DEAD=0 S DEAD=""
65 S LAST=$$FMTE^XLFDT($P(NODE,"^",4)) I LAST=0 S LAST=""
66 W !,$P(NODE,"^"),?31,SSN,?50,$$FMTE^XLFDT($P(NODE,"^",3)),?70,LAST,?100,DEAD
67 ;NAME,SSN,DOB,LAST DATE OF CONTACT,DATE OF DEATH
68 Q
69 ;
70DATA2 ;
71 N TCT S TCT=0
72 F S TCT=$O(^TMP($J,"DG31",LP,TCT)) Q:TCT=""!(END="Y") D
73 .I $Y+2>IOSL D HEAD I END'="Y" S NX="Y"
74 .I END="Y" Q
75 .I $D(NX) K NX D DATA
76 .W !,?10,^TMP($J,"DG31",LP,TCT)
77 Q
78LTD(DFN) ; Find Last Treatment Date
79 ; Input: DFN - pointer to the patient in file #2
80 ; Output: LTD - Last Treatment Date (really last date seen at facility)
81 ;
82 N LTD,X
83 ; - if current inpatient, set LTD = today and quit
84 I $G(^DPT(DFN,.105)) S LTD=DT G LTDQ
85 ; - get the last discharge date
86 S LTD=+$O(^DGPM("ATID3",DFN,"")) S:LTD LTD=9999999.9999999-LTD\1 S:LTD>DT LTD=DT
87 ; - get the last registration date and compare to LTD
88 S X=+$O(^DPT(DFN,"DIS",0)) I X S X=9999999-X\1 S:X>LTD LTD=X
89 ; - get the last appointment and compare to LTD
90 S X=LTD F S X=$O(^DPT(DFN,"S",X)) Q:'X!(X>DT) I $D(^(X,0)),$P(^(0),"^",2)="" S LTD=X\1
91 ; - get the last stop and compare to LTD
92 S X=LTD F S X=$O(^SDV("ADT",DFN,X)) Q:'X S LTD=X
93LTDQ Q LTD
94 ;
95KILL ;Delete pointer from Patient file
96 S DA(1)=DFN,DA=CNT,DIK="^DPT("_DA(1)_",.372," D ^DIK K DIK,DA
97 Q
Note: See TracBrowser for help on using the repository browser.