source: FOIAVistA/trunk/r/INCIDENT_REPORTING-QAN/QANCDNT.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 8.9 KB
Line 
1QANCDNT ;HISC/GJC-Initial sighting of an incident ; 10/29/03 10:39am
2 ;;2.0;Incident Reporting;**1,9,14,27,26,28,29,30,32**;08/07/1992;Build 3
3 ;
4 ;
5 N QANQFLG
6 D NEWREC ;I $G(QANLOCK)=1 L -^QA(742.4) S QANLOCK=0 Q
7 D DIV
8 I $G(QANQFLG)=1 D DEL Q
9 D DIE
10 Q
11NEWREC ;create new record number
12 ;record number will be in the format XXX.YYnnnn where XXX is the
13 ;three digit station number, YY is the 2 digit year and nnnn is
14 ;the sequence number (and is also the IEN of file 742.4)
15 N EE,QANCNT,QANLIST,QANNO,QANQFLG
16 K QANLOCK
17 S (QANFLAG,QANXIT,QANOUT)=0,QANST=$S($D(^QA(740,1,0))#2:$P(^(0),"^"),1:""),QANST1=$S($D(^DIC(4,QANST,99))#2:$P(^(99),"^"),1:QANST)
18 S QANDUZ=$S($D(DUZ):DUZ,1:""),QANTTL=$P(^VA(200,QANDUZ,0),U,9)
19 ;set QANDT variable as "." concatonated with 2 digit year so that
20 ;years 2000-2009 don't have leading zeroes.
21 S QANDT=$S($D(DT):$E(DT,2,3),1:""),QANDT="."_QANDT
22 S QANINCR=+$P($G(^QA(742.4,0)),U,3)+1 ;Grab the new IEN
23 F Q:$D(^QA(742.4,QANINCR,0))=0 S QANINCR=QANINCR+1
24 S QANCODE(0)=QANDT_QANINCR
25 I $L(QANINCR)<4 S QANCODE(0)=QANDT_$E("000",1,(4-$L(QANINCR)))_QANINCR
26 S QANCODE(1)=QANST1_QANCODE(0)
27 S QANCHK=$O(^QA(742.4,"B",QANCODE(1),0)) I +QANCHK,$D(^(QANCHK))#2 D Q
28 . W !!,$C(7),"CASE NUMBER VIOLATION, CONTACT YOUR QA COORDINATOR!!"
29 . S QANXIT=1
30 . K QANST,QANST1,QANDT,QANCODE,QANINCR,QANFLAG,QANOUT,QANDUZ,QANCHK,QANTTL
31 I $G(QANXIT)=1 Q
32 K DIC,DD,DO,DLAYGO,DINUM S (DIC,DIE)="^QA(742.4,",DIC(0)="L",X=QANCODE(1)
33 D FILE^DICN
34 K DIC,DD,DO,DLAYGO,DINUM
35 L +^QA(742.4,+Y):3 I '$T W !!,"Another user is editing this incident." S QANLOCK=1 Q
36 S QANBFLG=1 ;set brief flag so that if this subroutine was called
37 ;from full incident edit you do not re-lock the record when you
38 ;get back to full incident edit.
39 Q:+Y<1 S QANIEN=+Y
40 S QANHOME=$G(^QA(742.4,QANIEN,0)),$P(QANHOME,U,5)=QANDUZ,$P(QANHOME,U,6)=QANTTL,$P(QANHOME,U,15)=1,$P(QANHOME,U,8)=1
41 K DA,DIK S DIK="^QA(742.4,",DA=QANIEN,^QA(742.4,QANIEN,0)=QANHOME D IX1^DIK K DA,DIK
42 Q
43DIV ;check to see if station is multi-divisional for Incid Reporting. If
44 ;so, and there are hosp locations in file 740 (node "QAN2") then
45 ;prompt user for Division.
46 I $P($G(^QA(740,1,"QAN")),U,5)=1 S TEMPY=$G(Y) D S Y=$G(TEMPY)
47 . W !!,"DIVISION: "
48 . S QANCNT=0 S QANLIST="S EE=0 F S EE=$O(^QA(740,1,""QAN2"",EE)) Q:EE'>0 W !?5,EE,?10,$P(^DIC(4,$P(^QA(740,1,""QAN2"",EE,0),U),0),U) S QANCNT=QANCNT+1"
49LIST . S QANCNT=0 X QANLIST
50 . I $G(QANCNT)<1 W !?5,"There are no divisions entered in your QA Site Parameter File (#704).",!?5,"Ask your IRM support person to edit this file. If your site"
51 . I $G(QANCNT)<1 W !?5,"is entered in file #740 as a MULTI-DIVISIONAL INCID REP FACILITY you need",!?5,"entries in the IR HOSPITAL DIVISION multiple."
52 . S DIR(0)="NA"
53 . S DIR("A")="Enter the number of your choice: "
54 . S DIR("?")="Choose the number of your division."
55 . S DIR("??")="^S X=QANCNT X QANLIST"
56 . D ^DIR
57 . I $G(Y)']""!($G(Y)="^") D
58 . . W !!?5,"You must enter a Division.",!
59 . . D ^DIR
60 . . I $G(Y)']""!($G(Y)="^") S QANQFLG=1 Q
61 . I $G(QANQFLG)=1 Q
62 . I '$G(^QA(740,1,"QAN2",+Y,0)) W !,"Enter the number of your choice." S QANCNT=0 G LIST
63 . S QANNO=+Y
64 . S DIE="^QA(742.4,",DR="52///^S X=$P(^DIC(4,+^QA(740,1,""QAN2"",QANNO,0),0),U)"
65 . S DA=QANIEN
66 . D ^DIE I $D(Y)>0 S QANCNT=0 G LIST
67 Q
68DIE S DIE="^QA(742.4,",DA=QANIEN,DR="[QAN ENTER TIME]"
69 D ^DIE K DIE,DR I $D(Y) D DEL Q:QANXIT
70 S QANST=$P(^QA(742.4,QANIEN,0),U,2) I "12"[$P(^QA(742.1,QANST,0),U,2) S $P(^QA(742.4,QANIEN,0),U,9)=DT,QAQADICT=742.4,QAQAFLD=".1",X=DT D ENSET^QAQAXREF
71 K ^UTILITY($J,"QAN PAT") F D PAT Q:QANXIT!(QANOUT) ;get the patient
72 Q:QANXIT
73SC1 ;
74 K Y S DIE="^QA(742.4,",DA=QANIEN,DR=".05;@1;.08;S X=X" D ^DIE K DIE,DR I $D(Y) Q:QANXIT
75 K QAUDIT S QAUDIT("FILE")="742.4^50",QAUDIT("DA")=QANIEN,QAUDIT("ACTION")="o",QAUDIT("COMMENT")="Open an incident record" D ^QAQAUDIT
76 S DIE="^QA(742.4,",DR=".09///"_1,DA=QANIEN D ^DIE ; Set 'Local Case' flag to open.
77 I $G(QANFFLG)<1 D DISP
78 I $G(QANFFLG)<0 L -^QA(742.4,QANIEN) ;if this subroutine has not
79 ;been called from the full incident edit, then unlock incident report.
80 ;D ^QANBRIF ;transmit message to local mail group
81 Q
82DEL ;Delete incident.
83 K DIK S DIK="^QA(742.4,",DA=QANIEN W !!,$C(7),"Insufficient data entered for an incident, deleting!!" D ^DIK K DA,DIK S QANXIT=1
84 Q
85PAT ;Patient data.
86 K DIC S DIC="^DPT(",DIC(0)="QEAMNZ",DIC("A")="Select Patient: ",DIC("W")="W "" "",$P(^(0),U,9)",D="B^BS5"
87 D MIX^DIC1 K DIC S:+Y<1&($G(QANFLAG)) QANOUT=1
88 D:+Y<1&('$G(QANFLAG)) DEL^QANCDNT Q:QANXIT!(QANOUT)
89 F D Q:"-12"[%
90 . W !?5,$G(Y(0,0))_" OK?"
91 . S %=1 D YN^DICN Q:"-12"[%
92 . W " Confirm that this is the correct patient."
93 D:%=-1&('$G(QANFLAG)) DEL^QANCDNT Q:QANXIT!(QANOUT)
94 I %=-1,($G(QANFLAG)) S QANXIT=1 Q
95 I %=2 W " ??" G PAT
96 D PRIOR I QANXIT D Q
97 . I '$G(QANFLAG) K DA,DIK S DA=QANIEN,DIK="^QA(742.4," D ^DIK K DA,DIK
98 I $D(^UTILITY($J,"QAN PAT",+Y)) W !!,$C(7),$P(^DPT(+Y,0),U)_" has been previously entered for this incident." K Y G PAT
99 I $D(^DPT(+Y,.35)),$P(^DPT(+Y,.35),U)]"",($P(^DPT(+Y,.35),U)<$P(^QA(742.4,QANIEN,0),U,3)) W !!,$C(7),"The date of death for patient: "_$P(^DPT(+Y,0),U)_" precedes the incident date." K Y G PAT
100 I $G(QANXIT)!($G(QANOUT)) D DEL Q
101 S QANPIEN=+Y,QANZERO=Y(0),QANAME=Y(0,0),QANSSN=$P(QANZERO,U,9),^UTILITY($J,"QAN PAT",+Y)=""
102 S QANDOB=$P(^DPT(QANPIEN,0),U,3)
103 I QANDOB]"" S X=DT,X1=X,X2=QANDOB,X="" D:X2 ^%DTC S X=X\365.25,QANAGE=X
104 S QANPSDO(0)=Y(0),QANPSDO(0,0)=Y(0,0)
105 S QANPID=$$QANPID(.Y)
106 D ADMDT^QANUTL1
107 K DIC,DD,DO,DINUM,DLAYGO S DLAYGO=742,DIC="^QA(742,",DIC(0)="L",X=QANPIEN D FILE^DICN K DIC,DD,DO,DINUM,DLAYGO
108 I +Y=-1,('$G(QANFLAG)) D DEL Q
109 I +Y=-1,($G(QANFLAG)) S QANXIT=1 Q ;Something is wrong, exit.
110 S QANDFN=+Y
111 L +^QA(742,QANDFN):10 I '$T W !!,"Another user is editing this patient incident." Q
112 S $P(^QA(742,QANDFN,0),U,2,6)=QANPID_U_QANIEN_U_QANADMDT_U_QANINPAT_U_QANWARD
113 S $P(^QA(742,QANDFN,0),U,7)=QANTRSP,$P(^QA(742,QANDFN,0),U,12)=1
114 S DIK="^QA(742,",DA=QANDFN D IX1^DIK K DA,DIK
115 L -^QA(742,QANDFN)
116 S QANFLAG=1 ;D:'$D(QANF) BULL^QANUTL3
117 K QAUDIT S QAUDIT("FILE")="742^50",QAUDIT("DA")=QANDFN,QAUDIT("ACTION")="o",QAUDIT("COMMENT")="Open a patient record" D ^QAQAUDIT
118 Q
119PRIOR ;
120 S QANTST(1)=$G(^QA(742.4,QANIEN,0))
121 S QANTST("INC")=$P(QANTST(1),U,2),QANTST("DATE")=$P(QANTST(1),U,3)
122 F QAN99=0:0 S QAN99=$O(^QA(742,"AA",+Y,QAN99)) Q:QAN99'>0!(QANXIT) S QANPRS=+$O(^QA(742,"AA",+Y,QAN99,"")) I QANPRS>0,($P(^QA(742,QANPRS,0),U,12)'<0) S QANTST(2)=$G(^QA(742.4,QAN99,0)) D PRIOR1
123 K QAN99,QANPRS,QANTST
124 Q
125PRIOR1 ;
126 I (QANTST("INC")=$P(QANTST(2),U,2)),(QANTST("DATE")=$P(QANTST(2),U,3)) D
127 . W !!,$C(7),"Patient "_$P(^DPT(+Y,0),U)_" has a duplicate incident on record."
128 . W:'$G(QANFLAG) !,"Deleting the incident."
129 . S:'$G(QANFLAG) QANXIT=1
130 . W:$G(QANFLAG) !,"Please select new patient or press 'RETURN'!"
131 ; . W:$G(QANFLAG) !,"Exiting!"
132 ; . S QANXIT=1
133 Q
134DISP ;display to user what has been entered and ask if it is okay
135 N QANCC,QANEE
136 W @IOF
137 S QAN74240=^QA(742.4,QANIEN,0)
138 W !!!,"Incident Report: "_$P(QAN74240,U)
139 S Y=$P(QAN74240,U,3) D DD^%DT
140 W ?35,"Date of Incident: "_Y
141 W !,"Patient: "
142 S QANCC=0 F S QANCC=$O(^QA(742,"BCS",QANIEN,QANCC)) Q:QANCC'>0 D
143 . W ?10,$P(^DPT($P(^QA(742,QANCC,0),U),0),U),!
144 W !,"Incident Type: "
145 I $P(QAN74240,U,2)]"" W $P(^QA(742.1,$P(QAN74240,U,2),0),U)
146 W !,"Incident Location: "
147 I $P(QAN74240,U,4)]"" W $P(^QA(742.5,$P(QAN74240,U,4),0),U)
148 W !,"Was the Incident Witnessed?: "_$S($P(QAN74240,U,7)=1:"Yes",$P(QAN74240,U,7)=0:"No",1:"")
149 W !,"Incident Description: "
150 S QANEE=0 F S QANEE=$O(^QA(742.4,QANIEN,1,QANEE)) Q:QANEE'>0 D
151 . W !?3,^QA(742.4,QANIEN,1,QANEE,0)
152 W !!
153 S DIR("A")="Is this information correct?"
154 S DIR("B")="Yes"
155 S DIR("?")="Enter 'Yes' or 'No'."
156 S DIR(0)="YAO"
157 S DIR("?",1)="Enter 'Yes' if the information displayed is correct."
158 S DIR("?",2)="Enter 'No' if you need to edit this information."
159 D ^DIR
160GOEDIT ;
161 ;if info is not right, use code from QANEDIT to edit just the fields
162 ;in a brief incident. There must be at least one patient/report.
163 I Y=0 S QANOUT=0 D
164 . D DIE^QANEDIT
165 . I $O(^QA(742,"BCS",QANIEN,0))']"" D
166 . . W !!,"No patients on this Incident Report - deleting Report."
167 . . S DIK="^QA(742.4,",DA=QANIEN D ^DIK K DIK
168 . . ;also need to remove entry from QA Audit file (#740.5)
169 . . ;get most recent entry for 742 and 742.4 and if matches
170 . . ;this entry, delete
171 . . F QANFILE=742,742.4 D DIKAUDIT^QANEDIT(QANFILE) K QANFILE
172 I $G(^QA(742.4,QANIEN,0))]"" D
173 . D ^QANBRIF ;transmit message to local mail group
174 . S QANCC=0
175 . F S QANCC=$O(^QA(742,"BCS",QANIEN,QANCC)) Q:QANCC'>0 D
176 . . S QANPTNUM=$P(^QA(742,QANCC,0),U)
177 . . S QANODE=^DPT(QANPTNUM,0)
178 . . S QANAME=$P(QANODE,U)
179 . . S QANSSN=$P(QANODE,U,9)
180 . . D:'$D(QANF) BULL^QANUTL3
181QANPID(Y) ;Function to set up Patient ID.
182 N QANF,QANM,QANL
183 S QANL=$P(Y(0,0),",")
184 I QANL[" " D
185 .S QANF=$E($P(Y(0,0),",",2))
186 .S QANM=$E($P(Y(0,0)," ",3))
187 .S QANPID=$G(QANF)_$G(QANM)_$E(QANL)_$E(QANSSN,6,9)
188 I QANL'[" " D
189 .S QANF=$E($P(Y(0,0),",",2))
190 .S QANM=$E($P(Y(0,0)," ",2))
191 .S QANPID=$G(QANF)_$G(QANM)_$E(QANL)_$E(QANSSN,6,9)
192 Q QANPID
193 Q
Note: See TracBrowser for help on using the repository browser.