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

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

WorldVistAEHR overlayed on FOIAVistA

File size: 6.0 KB
Line 
1DGDEATH ;ALB/MRL/PJR-PROCESS DECEASED PATIENTS ; 10/27/04 9:45pm
2 ;;5.3;Registration;**45,84,101,149,392,545,595,568,563,725**;Aug 13, 1993;Build 12
3 ;
4GET N DGMTI,DATA
5 S DGDTHEN="" W !! S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G Q:Y'>0 S (DA,DFN)=+Y
6 S DGDOLD=$G(^DPT(DFN,.35))
7 I $D(^DPT(DFN,.1)) W !?3,"Patient is currently in-house. Discharge him with a discharge type of DEATH." G GET
8 I $S($D(^DPT(DFN,.35)):^(.35),1:"") F DGY=0:0 S DGY=$O(^DGPM("ATID1",DFN,DGY)) Q:'DGY S DGDA=$O(^(DGY,0)) I $D(^DGPM(+DGDA,0)),$P(^(0),"^",17)]"" S DGXX=$P(^(0),"^",17),DGXX=^DGPM(DGXX,0) I "^12^38^"[("^"_$P(DGXX,"^",18)_"^") G DIS
9 D NOW^%DTC S DGNOW=%
10 S ^TMP("DEATH",$J)=1
11 K A W ! S DIE=DIC,DR=".351" D ^DIE
12 I '$D(^DPT(DFN,.35)) K ^TMP("DEATH",$J) G GET
13 S DGDNEW=^DPT(DFN,.35)
14 I $P(DGDNEW,"^",1)="",$P(DGDNEW,"^",2)'="" S DR=".352////@" D ^DIE
15 I $P(DGDNEW,"^",1)="" K ^TMP("DEATH",$J) G GET
16 I $P(DGDNEW,"^",1)'="" S DR=".353" D ^DIE
17 I DGDOLD'=DGDNEW D DISCHRGE
18 I $P(DGDOLD,"^",1)'=$P(DGDNEW,"^",1) D XFR
19 K ^TMP("DEATH",$J) G GET
20 ;
21DIS W !,"Patient has a discharge type of Death",!,"Edit the discharge",!
22Q K A,DA,DFN,DGDA,DIC,DIE,DR,DGXX,DGY,DGDTHEN,DGDOLD,DGDNEW,DGDONOT Q
23XFR ; called from set x-ref of field .351 of file 2
24 N DGPCMM,DGFAPT,DGFAPTI,DGFAPT1
25 Q:'$D(DFN)
26 K DGTEXT D ^DGPATV S DGDEATH=$$GET1^DIQ(2,DFN,.351,"I"),XMSUB="PATIENT HAS EXPIRED",DGCT=0
27 D DEMOG
28 S DGT=X-.0001,(Y,DGDDT)=X,DG1="" D:DGT]"" ^DGPMSTAT
29 S Y=$$FMTE^XLFDT(Y),Y=$S(Y]"":Y,1:"UNKNOWN")
30 S DGDONOT=0 D APTT3
31 D LINE("")
32 D LINE(" Date/Time of Death: "_DEATHVAL_$S(DGDONOT:"",'DG1:"",$D(DGDTHEN):"",1:" (While an inpatient)"))
33 D LINE("")
34 I '$D(ADM),DG1,$D(^DGPM(+DGA1,0)) S ADM=+^DGPM($P(^(0),"^",14),0)
35 S Y=$$FMTE^XLFDT($S($D(ADM):ADM,1:""))
36 D LINE($S($D(DGDTHEN):"",DG1:" Admission Date/Time: "_Y_$S((DGDDT-ADM)<1:" (Within 24 hours of hospitalization)",1:""),1:""))
37 D LINE("")
38 S DGX=$P($G(^DGPM(+$G(DGA1),0)),"^",6),DGX=$P($G(^DIC(42,+DGX,0)),U,1)
39 D LINE($S($D(DGDTHEN):"",('DG1):"",$D(DGA1):" Admitted To: "_$S(DGX]"":DGX,1:"UNKNOWN"),1:"")) K DGX
40 D LINE("")
41 I DG1&'$D(DGDTHEN) D
42 . D LINE($S($D(DGXFR0):" Last Transfer: "_$S($D(^DIC(42,+$P(DGXFR0,"^",6),0)):$P(^(0),"^"),1:"UNKNOWN"),1:""))
43 . D LINE("")
44F N DGARRAY,SDCNT S DGFAPT=DGDEATH,DGFAPTI=""
45 S DGARRAY("FLDS")=3,DGARRAY(4)=DFN,DGARRAY("SORT")="P",DGARRAY(1)=DT,DGARRAY(3)="I;R"
46 S SDCNT=$$SDAPI^SDAMA301(.DGARRAY)
47 ;
48 I SDCNT>0 F S DGFAPT=$O(^TMP($J,"SDAMA301",DFN,DGFAPT)) Q:'DGFAPT S DGFAPT1=$G(^TMP($J,"SDAMA301",DFN,DGFAPT)) Q:DGFAPT1']"" D Q:DGFAPTI
49 .I $P($P(DGFAPT1,U,3),";")'["C" D LINE("NOTE: Patient has future appointments scheduled!!") S DGFAPTI=1
50 S DGSCHAD=0 D SA I DGSCHAD D LINE("NOTE: Patient had scheduled admissions which have been cancelled!!")
51 I 'DGVETS D LINE("Patient is a NON-VETERAN."_$S($D(^DIC(21,+$P($G(^DPT(DFN,.32)),"^",3),0)):" ["_$P(^(0),"^",1)_"]",1:""))
52 S DGPCMM=$$PCMMXMY^SCAPMC25(1,DFN,,,0) ;creates xmy array
53 S DGCT=$$PCMAIL^SCMCMM(DFN,"DGTEXT",DT)
54Q1 S DGB=1 D ^DGBUL S X=DGDEATH
55 K DGDEATH,DGSCHAD,DGI,Y,DGDDT,^TMP($J,"SDAMA301") D KILL^DGPATV K ADM,DG1,DGA1,DGCT,DGT,DGXX,DGY,Z Q
56SA F DGI=0:0 S DGI=$O(^DGS(41.1,"B",DFN,DGI)) Q:'DGI I $D(^DGS(41.1,DGI,0)),($P(^(0),"^",13)']""),($P(^(0),"^",17)']"") S $P(^(0),"^",13)=DGDEATH,$P(^(0),"^",14)=+DUZ,$P(^(0),"^",15)=1,$P(^(0),"^",16)=2,DGSCHAD=1
57 Q
58 ;
59DEL ; delete death bulletin
60 N DGPCMM,DELBY,DELTM,DTHINFO
61 S DFN=+$G(DA) I '$D(^DPT(DFN,0)) Q ; no patient node
62 I +$G(^DPT(DFN,.35)) Q ; not deletion
63 S DGDEATH=X,XMSUB="Patient Death has been Deleted",DGCT=0
64 D ^DGPATV
65 D LINE("The date of death for the following patient has been deleted.")
66 D LINE("")
67 D DEMOG
68 D LINE("")
69 S DGPCMM=$$PCMMXMY^SCAPMC25(1,DFN,,,0) ;creates xmy array
70 S DGCT=$$PCMAIL^SCMCMM(DFN,"DGTEXT",DT)
71 S DGB=1 D ^DGBUL S X=DGDEATH
72 K DGCT,DGDEATH D KILL^DGPATV
73 Q
74 ;
75DEMOG ; list main demographics
76 D LINE(" NAME: "_DGNAME)
77 D LINE(" SSN: "_$P(SSN,"^",2))
78 D LINE(" DOB: "_$P(DOB,"^",2))
79 I DGVETS D
80 . N DGX
81 . S DGX=$G(^DPT(DFN,.31))
82 . S DGLOCATN=$$FIND1^DIC(4,"","MX","`"_+$P(DGX,U,4)),DGLOCATN=$S(+DGLOCATN>0:$P($$NS^XUAF4(DGLOCATN),U),1:"NOT LISTED")
83 . D LINE(" CLAIM FOLDER LOCATION: "_$S($D(DGLOCATN):DGLOCATN,1:"NOT LISTED"))
84 . D LINE(" CLAIM NUMBER: "_$S($P(DGX,"^",3)]"":$P(DGX,"^",3),1:"NOT LISTED"))
85 D LINE(" COORDINATING MASTER OF RECORD: "_DGCMOR)
86 D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","DTHINFO")
87 S DEATHVAL=$G(DTHINFO(2,DFN_",",.351,"E"))
88 S DEATHVAL=$$FMTE^XLFDT(DEATHVAL),DEATHVAL=$S(DEATHVAL]"":DEATHVAL,1:"UNKNOWN")
89 S SOURCE=$G(DTHINFO(2,DFN_",",.353,"E"))
90 S DELTM=$G(DTHINFO(2,DFN_",",.354,"E"))
91 S DELBY=$G(DTHINFO(2,DFN_",",.355,"E"))
92 D LINE("")
93 D LINE(" LAST EDITED BY: "_DELBY)
94 D LINE(" DATE/TIME LAST MODIFIED: "_DELTM)
95 D LINE(" SOURCE OF NOTIFICATION: "_$S(SOURCE="":"UNDEFINED",1:SOURCE))
96 ;K DEATHVAL,SOURCE,DELTM,DELBY
97 Q
98 ;
99LINE(X) ; add line contained in X to array
100 S DGCT=DGCT+1
101 S DGTEXT(DGCT,0)=X
102 Q
103DSBULL ;
104 ;
105 I $G(IVMDODUP)=1 Q
106 S DFN=DA
107 I $D(DGPMDA) D Q
108 .S DISTYPE=$P($G(^DGPM(DGPMDA,0)),"^",18)
109 .I $G(^DG(405.2,DISTYPE,0))["DEATH" D
110 ..S FDA(2,DFN_",",.353)=1 D FILE^DIE(,"FDA","BWFERR")
111 ..D DISCHRGE,XFR
112 I $D(^TMP("DEATH",$J)) Q
113 D DISCHRGE,XFR
114 Q
115DKBULL ;
116 S DFN=DA
117 S FDA(2,DFN_",",.353)="@"
118 I $D(^TMP("DEATH",$J)) S FDA(2,DFN_",",.355)=DUZ
119 D FILE^DIE(,"FDA",)
120 D DEL
121 Q
122DISCHRGE ;
123 ; If the patient is being discharged, determine values needed for
124 ; Source of Notification and Date/Time last entered.
125 ;
126 I '$D(DGNOW) S DGNOW=$$HTFM^XLFDT($H)
127 I $G(DGDAUTO)'=1 S FDA(2,DFN_",",.354)=DGNOW
128 S FDA(2,DFN_",",.355)=DUZ
129 D FILE^DIE(,"FDA",)
130 Q
131APTT3 ;Check to exclude "While an Inpatient" from DOD Bulletin
132 ; Input: DFN Output: DGDONOT
133 N DATE,XIEN,TYPE,XDOD,YES
134 S DGDONOT=0
135 S XDOD=$P($G(^DPT(DFN,.35)),"^",1) I 'XDOD Q
136 S XDOD=$P(XDOD,".",1),YES=0,TYPE=""
137 I '$D(^DGPM("APTT3",DFN)) Q
138 S DATE=$O(^DGPM("APTT3",DFN,XDOD)) I 'DATE Q
139 I $P(DATE,".",1)=XDOD S YES=1
140 I ($P(DATE,".",1)-1)=XDOD S YES=1
141 S XIEN=$O(^DGPM("APTT3",DFN,DATE,"")) I 'XIEN Q
142 S TYPE=$P($G(^DGPM(XIEN,0)),"^",4)
143 I YES,'((TYPE=27)!(TYPE=32)) S DGDONOT=1
144 Q
Note: See TracBrowser for help on using the repository browser.