QANCDNT ;HISC/GJC-Initial sighting of an incident ; 10/29/03 10:39am
;;2.0;Incident Reporting;**1,9,14,27,26,28,29,30,32**;08/07/1992;Build 3
;
;
N QANQFLG
D NEWREC ;I $G(QANLOCK)=1 L -^QA(742.4) S QANLOCK=0 Q
D DIV
I $G(QANQFLG)=1 D DEL Q
D DIE
Q
NEWREC ;create new record number
;record number will be in the format XXX.YYnnnn where XXX is the
;three digit station number, YY is the 2 digit year and nnnn is
;the sequence number (and is also the IEN of file 742.4)
N EE,QANCNT,QANLIST,QANNO,QANQFLG
K QANLOCK
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)
S QANDUZ=$S($D(DUZ):DUZ,1:""),QANTTL=$P(^VA(200,QANDUZ,0),U,9)
;set QANDT variable as "." concatonated with 2 digit year so that
;years 2000-2009 don't have leading zeroes.
S QANDT=$S($D(DT):$E(DT,2,3),1:""),QANDT="."_QANDT
S QANINCR=+$P($G(^QA(742.4,0)),U,3)+1 ;Grab the new IEN
F Q:$D(^QA(742.4,QANINCR,0))=0 S QANINCR=QANINCR+1
S QANCODE(0)=QANDT_QANINCR
I $L(QANINCR)<4 S QANCODE(0)=QANDT_$E("000",1,(4-$L(QANINCR)))_QANINCR
S QANCODE(1)=QANST1_QANCODE(0)
S QANCHK=$O(^QA(742.4,"B",QANCODE(1),0)) I +QANCHK,$D(^(QANCHK))#2 D Q
. W !!,$C(7),"CASE NUMBER VIOLATION, CONTACT YOUR QA COORDINATOR!!"
. S QANXIT=1
. K QANST,QANST1,QANDT,QANCODE,QANINCR,QANFLAG,QANOUT,QANDUZ,QANCHK,QANTTL
I $G(QANXIT)=1 Q
K DIC,DD,DO,DLAYGO,DINUM S (DIC,DIE)="^QA(742.4,",DIC(0)="L",X=QANCODE(1)
D FILE^DICN
K DIC,DD,DO,DLAYGO,DINUM
L +^QA(742.4,+Y):3 I '$T W !!,"Another user is editing this incident." S QANLOCK=1 Q
S QANBFLG=1 ;set brief flag so that if this subroutine was called
;from full incident edit you do not re-lock the record when you
;get back to full incident edit.
Q:+Y<1 S QANIEN=+Y
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
K DA,DIK S DIK="^QA(742.4,",DA=QANIEN,^QA(742.4,QANIEN,0)=QANHOME D IX1^DIK K DA,DIK
Q
DIV ;check to see if station is multi-divisional for Incid Reporting. If
;so, and there are hosp locations in file 740 (node "QAN2") then
;prompt user for Division.
I $P($G(^QA(740,1,"QAN")),U,5)=1 S TEMPY=$G(Y) D S Y=$G(TEMPY)
. W !!,"DIVISION: "
. 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"
LIST . S QANCNT=0 X QANLIST
. 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"
. 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."
. S DIR(0)="NA"
. S DIR("A")="Enter the number of your choice: "
. S DIR("?")="Choose the number of your division."
. S DIR("??")="^S X=QANCNT X QANLIST"
. D ^DIR
. I $G(Y)']""!($G(Y)="^") D
. . W !!?5,"You must enter a Division.",!
. . D ^DIR
. . I $G(Y)']""!($G(Y)="^") S QANQFLG=1 Q
. I $G(QANQFLG)=1 Q
. I '$G(^QA(740,1,"QAN2",+Y,0)) W !,"Enter the number of your choice." S QANCNT=0 G LIST
. S QANNO=+Y
. S DIE="^QA(742.4,",DR="52///^S X=$P(^DIC(4,+^QA(740,1,""QAN2"",QANNO,0),0),U)"
. S DA=QANIEN
. D ^DIE I $D(Y)>0 S QANCNT=0 G LIST
Q
DIE S DIE="^QA(742.4,",DA=QANIEN,DR="[QAN ENTER TIME]"
D ^DIE K DIE,DR I $D(Y) D DEL Q:QANXIT
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
K ^UTILITY($J,"QAN PAT") F D PAT Q:QANXIT!(QANOUT) ;get the patient
Q:QANXIT
SC1 ;
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
K QAUDIT S QAUDIT("FILE")="742.4^50",QAUDIT("DA")=QANIEN,QAUDIT("ACTION")="o",QAUDIT("COMMENT")="Open an incident record" D ^QAQAUDIT
S DIE="^QA(742.4,",DR=".09///"_1,DA=QANIEN D ^DIE ; Set 'Local Case' flag to open.
I $G(QANFFLG)<1 D DISP
I $G(QANFFLG)<0 L -^QA(742.4,QANIEN) ;if this subroutine has not
;been called from the full incident edit, then unlock incident report.
;D ^QANBRIF ;transmit message to local mail group
Q
DEL ;Delete incident.
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
Q
PAT ;Patient data.
K DIC S DIC="^DPT(",DIC(0)="QEAMNZ",DIC("A")="Select Patient: ",DIC("W")="W "" "",$P(^(0),U,9)",D="B^BS5"
D MIX^DIC1 K DIC S:+Y<1&($G(QANFLAG)) QANOUT=1
D:+Y<1&('$G(QANFLAG)) DEL^QANCDNT Q:QANXIT!(QANOUT)
F D Q:"-12"[%
. W !?5,$G(Y(0,0))_" OK?"
. S %=1 D YN^DICN Q:"-12"[%
. W " Confirm that this is the correct patient."
D:%=-1&('$G(QANFLAG)) DEL^QANCDNT Q:QANXIT!(QANOUT)
I %=-1,($G(QANFLAG)) S QANXIT=1 Q
I %=2 W " ??" G PAT
D PRIOR I QANXIT D Q
. I '$G(QANFLAG) K DA,DIK S DA=QANIEN,DIK="^QA(742.4," D ^DIK K DA,DIK
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
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
I $G(QANXIT)!($G(QANOUT)) D DEL Q
S QANPIEN=+Y,QANZERO=Y(0),QANAME=Y(0,0),QANSSN=$P(QANZERO,U,9),^UTILITY($J,"QAN PAT",+Y)=""
S QANDOB=$P(^DPT(QANPIEN,0),U,3)
I QANDOB]"" S X=DT,X1=X,X2=QANDOB,X="" D:X2 ^%DTC S X=X\365.25,QANAGE=X
S QANPSDO(0)=Y(0),QANPSDO(0,0)=Y(0,0)
S QANPID=$$QANPID(.Y)
D ADMDT^QANUTL1
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
I +Y=-1,('$G(QANFLAG)) D DEL Q
I +Y=-1,($G(QANFLAG)) S QANXIT=1 Q ;Something is wrong, exit.
S QANDFN=+Y
L +^QA(742,QANDFN):10 I '$T W !!,"Another user is editing this patient incident." Q
S $P(^QA(742,QANDFN,0),U,2,6)=QANPID_U_QANIEN_U_QANADMDT_U_QANINPAT_U_QANWARD
S $P(^QA(742,QANDFN,0),U,7)=QANTRSP,$P(^QA(742,QANDFN,0),U,12)=1
S DIK="^QA(742,",DA=QANDFN D IX1^DIK K DA,DIK
L -^QA(742,QANDFN)
S QANFLAG=1 ;D:'$D(QANF) BULL^QANUTL3
K QAUDIT S QAUDIT("FILE")="742^50",QAUDIT("DA")=QANDFN,QAUDIT("ACTION")="o",QAUDIT("COMMENT")="Open a patient record" D ^QAQAUDIT
Q
PRIOR ;
S QANTST(1)=$G(^QA(742.4,QANIEN,0))
S QANTST("INC")=$P(QANTST(1),U,2),QANTST("DATE")=$P(QANTST(1),U,3)
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
K QAN99,QANPRS,QANTST
Q
PRIOR1 ;
I (QANTST("INC")=$P(QANTST(2),U,2)),(QANTST("DATE")=$P(QANTST(2),U,3)) D
. W !!,$C(7),"Patient "_$P(^DPT(+Y,0),U)_" has a duplicate incident on record."
. W:'$G(QANFLAG) !,"Deleting the incident."
. S:'$G(QANFLAG) QANXIT=1
. W:$G(QANFLAG) !,"Please select new patient or press 'RETURN'!"
; . W:$G(QANFLAG) !,"Exiting!"
; . S QANXIT=1
Q
DISP ;display to user what has been entered and ask if it is okay
N QANCC,QANEE
W @IOF
S QAN74240=^QA(742.4,QANIEN,0)
W !!!,"Incident Report: "_$P(QAN74240,U)
S Y=$P(QAN74240,U,3) D DD^%DT
W ?35,"Date of Incident: "_Y
W !,"Patient: "
S QANCC=0 F S QANCC=$O(^QA(742,"BCS",QANIEN,QANCC)) Q:QANCC'>0 D
. W ?10,$P(^DPT($P(^QA(742,QANCC,0),U),0),U),!
W !,"Incident Type: "
I $P(QAN74240,U,2)]"" W $P(^QA(742.1,$P(QAN74240,U,2),0),U)
W !,"Incident Location: "
I $P(QAN74240,U,4)]"" W $P(^QA(742.5,$P(QAN74240,U,4),0),U)
W !,"Was the Incident Witnessed?: "_$S($P(QAN74240,U,7)=1:"Yes",$P(QAN74240,U,7)=0:"No",1:"")
W !,"Incident Description: "
S QANEE=0 F S QANEE=$O(^QA(742.4,QANIEN,1,QANEE)) Q:QANEE'>0 D
. W !?3,^QA(742.4,QANIEN,1,QANEE,0)
W !!
S DIR("A")="Is this information correct?"
S DIR("B")="Yes"
S DIR("?")="Enter 'Yes' or 'No'."
S DIR(0)="YAO"
S DIR("?",1)="Enter 'Yes' if the information displayed is correct."
S DIR("?",2)="Enter 'No' if you need to edit this information."
D ^DIR
GOEDIT ;
;if info is not right, use code from QANEDIT to edit just the fields
;in a brief incident. There must be at least one patient/report.
I Y=0 S QANOUT=0 D
. D DIE^QANEDIT
. I $O(^QA(742,"BCS",QANIEN,0))']"" D
. . W !!,"No patients on this Incident Report - deleting Report."
. . S DIK="^QA(742.4,",DA=QANIEN D ^DIK K DIK
. . ;also need to remove entry from QA Audit file (#740.5)
. . ;get most recent entry for 742 and 742.4 and if matches
. . ;this entry, delete
. . F QANFILE=742,742.4 D DIKAUDIT^QANEDIT(QANFILE) K QANFILE
I $G(^QA(742.4,QANIEN,0))]"" D
. D ^QANBRIF ;transmit message to local mail group
. S QANCC=0
. F S QANCC=$O(^QA(742,"BCS",QANIEN,QANCC)) Q:QANCC'>0 D
. . S QANPTNUM=$P(^QA(742,QANCC,0),U)
. . S QANODE=^DPT(QANPTNUM,0)
. . S QANAME=$P(QANODE,U)
. . S QANSSN=$P(QANODE,U,9)
. . D:'$D(QANF) BULL^QANUTL3
QANPID(Y) ;Function to set up Patient ID.
N QANF,QANM,QANL
S QANL=$P(Y(0,0),",")
I QANL[" " D
.S QANF=$E($P(Y(0,0),",",2))
.S QANM=$E($P(Y(0,0)," ",3))
.S QANPID=$G(QANF)_$G(QANM)_$E(QANL)_$E(QANSSN,6,9)
I QANL'[" " D
.S QANF=$E($P(Y(0,0),",",2))
.S QANM=$E($P(Y(0,0)," ",2))
.S QANPID=$G(QANF)_$G(QANM)_$E(QANL)_$E(QANSSN,6,9)
Q QANPID
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQANCDNT 9278 printed Apr 09, 2024@21:01:19 Page 2
QANCDNT ;HISC/GJC-Initial sighting of an incident ; 10/29/03 10:39am
+1 ;;2.0;Incident Reporting;**1,9,14,27,26,28,29,30,32**;08/07/1992;Build 3
+2 ;
+3 ;
+4 NEW QANQFLG
+5 ;I $G(QANLOCK)=1 L -^QA(742.4) S QANLOCK=0 Q
DO NEWREC
+6 DO DIV
+7 IF $GET(QANQFLG)=1
DO DEL
QUIT
+8 DO DIE
+9 QUIT
NEWREC ;create new record number
+1 ;record number will be in the format XXX.YYnnnn where XXX is the
+2 ;three digit station number, YY is the 2 digit year and nnnn is
+3 ;the sequence number (and is also the IEN of file 742.4)
+4 NEW EE,QANCNT,QANLIST,QANNO,QANQFLG
+5 KILL QANLOCK
+6 SET (QANFLAG,QANXIT,QANOUT)=0
SET QANST=$SELECT($DATA(^QA(740,1,0))#2:$PIECE(^(0),"^"),1:"")
SET QANST1=$SELECT($DATA(^DIC(4,QANST,99))#2:$PIECE(^(99),"^"),1:QANST)
+7 SET QANDUZ=$SELECT($DATA(DUZ):DUZ,1:"")
SET QANTTL=$PIECE(^VA(200,QANDUZ,0),U,9)
+8 ;set QANDT variable as "." concatonated with 2 digit year so that
+9 ;years 2000-2009 don't have leading zeroes.
+10 SET QANDT=$SELECT($DATA(DT):$EXTRACT(DT,2,3),1:"")
SET QANDT="."_QANDT
+11 ;Grab the new IEN
SET QANINCR=+$PIECE($GET(^QA(742.4,0)),U,3)+1
+12 FOR
if $DATA(^QA(742.4,QANINCR,0))=0
QUIT
SET QANINCR=QANINCR+1
+13 SET QANCODE(0)=QANDT_QANINCR
+14 IF $LENGTH(QANINCR)<4
SET QANCODE(0)=QANDT_$EXTRACT("000",1,(4-$LENGTH(QANINCR)))_QANINCR
+15 SET QANCODE(1)=QANST1_QANCODE(0)
+16 SET QANCHK=$ORDER(^QA(742.4,"B",QANCODE(1),0))
IF +QANCHK
IF $DATA(^(QANCHK))#2
Begin DoDot:1
+17 WRITE !!,$CHAR(7),"CASE NUMBER VIOLATION, CONTACT YOUR QA COORDINATOR!!"
+18 SET QANXIT=1
+19 KILL QANST,QANST1,QANDT,QANCODE,QANINCR,QANFLAG,QANOUT,QANDUZ,QANCHK,QANTTL
End DoDot:1
QUIT
+20 IF $GET(QANXIT)=1
QUIT
+21 KILL DIC,DD,DO,DLAYGO,DINUM
SET (DIC,DIE)="^QA(742.4,"
SET DIC(0)="L"
SET X=QANCODE(1)
+22 DO FILE^DICN
+23 KILL DIC,DD,DO,DLAYGO,DINUM
+24 LOCK +^QA(742.4,+Y):3
IF '$TEST
WRITE !!,"Another user is editing this incident."
SET QANLOCK=1
QUIT
+25 ;set brief flag so that if this subroutine was called
SET QANBFLG=1
+26 ;from full incident edit you do not re-lock the record when you
+27 ;get back to full incident edit.
+28 if +Y<1
QUIT
SET QANIEN=+Y
+29 SET QANHOME=$GET(^QA(742.4,QANIEN,0))
SET $PIECE(QANHOME,U,5)=QANDUZ
SET $PIECE(QANHOME,U,6)=QANTTL
SET $PIECE(QANHOME,U,15)=1
SET $PIECE(QANHOME,U,8)=1
+30 KILL DA,DIK
SET DIK="^QA(742.4,"
SET DA=QANIEN
SET ^QA(742.4,QANIEN,0)=QANHOME
DO IX1^DIK
KILL DA,DIK
+31 QUIT
DIV ;check to see if station is multi-divisional for Incid Reporting. If
+1 ;so, and there are hosp locations in file 740 (node "QAN2") then
+2 ;prompt user for Division.
+3 IF $PIECE($GET(^QA(740,1,"QAN")),U,5)=1
SET TEMPY=$GET(Y)
Begin DoDot:1
+4 WRITE !!,"DIVISION: "
+5 SET QANCNT=0
SET 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"
LIST SET QANCNT=0
XECUTE QANLIST
+1 IF $GET(QANCNT)<1
WRITE !?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"
+2 IF $GET(QANCNT)<1
WRITE !?5,"is entered in file #740 as a MULTI-DIVISIONAL INCID REP FACILITY you need",!?5,"entries in the IR HOSPITAL DIVISION multiple."
+3 SET DIR(0)="NA"
+4 SET DIR("A")="Enter the number of your choice: "
+5 SET DIR("?")="Choose the number of your division."
+6 SET DIR("??")="^S X=QANCNT X QANLIST"
+7 DO ^DIR
+8 IF $GET(Y)']""!($GET(Y)="^")
Begin DoDot:2
+9 WRITE !!?5,"You must enter a Division.",!
+10 DO ^DIR
+11 IF $GET(Y)']""!($GET(Y)="^")
SET QANQFLG=1
QUIT
End DoDot:2
+12 IF $GET(QANQFLG)=1
QUIT
+13 IF '$GET(^QA(740,1,"QAN2",+Y,0))
WRITE !,"Enter the number of your choice."
SET QANCNT=0
GOTO LIST
+14 SET QANNO=+Y
+15 SET DIE="^QA(742.4,"
SET DR="52///^S X=$P(^DIC(4,+^QA(740,1,""QAN2"",QANNO,0),0),U)"
+16 SET DA=QANIEN
+17 DO ^DIE
IF $DATA(Y)>0
SET QANCNT=0
GOTO LIST
End DoDot:1
SET Y=$GET(TEMPY)
+18 QUIT
DIE SET DIE="^QA(742.4,"
SET DA=QANIEN
SET DR="[QAN ENTER TIME]"
+1 DO ^DIE
KILL DIE,DR
IF $DATA(Y)
DO DEL
if QANXIT
QUIT
+2 SET QANST=$PIECE(^QA(742.4,QANIEN,0),U,2)
IF "12"[$PIECE(^QA(742.1,QANST,0),U,2)
SET $PIECE(^QA(742.4,QANIEN,0),U,9)=DT
SET QAQADICT=742.4
SET QAQAFLD=".1"
SET X=DT
DO ENSET^QAQAXREF
+3 ;get the patient
KILL ^UTILITY($JOB,"QAN PAT")
FOR
DO PAT
if QANXIT!(QANOUT)
QUIT
+4 if QANXIT
QUIT
SC1 ;
+1 KILL Y
SET DIE="^QA(742.4,"
SET DA=QANIEN
SET DR=".05;@1;.08;S X=X"
DO ^DIE
KILL DIE,DR
IF $DATA(Y)
if QANXIT
QUIT
+2 KILL QAUDIT
SET QAUDIT("FILE")="742.4^50"
SET QAUDIT("DA")=QANIEN
SET QAUDIT("ACTION")="o"
SET QAUDIT("COMMENT")="Open an incident record"
DO ^QAQAUDIT
+3 ; Set 'Local Case' flag to open.
SET DIE="^QA(742.4,"
SET DR=".09///"_1
SET DA=QANIEN
DO ^DIE
+4 IF $GET(QANFFLG)<1
DO DISP
+5 ;if this subroutine has not
IF $GET(QANFFLG)<0
LOCK -^QA(742.4,QANIEN)
+6 ;been called from the full incident edit, then unlock incident report.
+7 ;D ^QANBRIF ;transmit message to local mail group
+8 QUIT
DEL ;Delete incident.
+1 KILL DIK
SET DIK="^QA(742.4,"
SET DA=QANIEN
WRITE !!,$CHAR(7),"Insufficient data entered for an incident, deleting!!"
DO ^DIK
KILL DA,DIK
SET QANXIT=1
+2 QUIT
PAT ;Patient data.
+1 KILL DIC
SET DIC="^DPT("
SET DIC(0)="QEAMNZ"
SET DIC("A")="Select Patient: "
SET DIC("W")="W "" "",$P(^(0),U,9)"
SET D="B^BS5"
+2 DO MIX^DIC1
KILL DIC
if +Y<1&($GET(QANFLAG))
SET QANOUT=1
+3 if +Y<1&('$GET(QANFLAG))
DO DEL^QANCDNT
if QANXIT!(QANOUT)
QUIT
+4 FOR
Begin DoDot:1
+5 WRITE !?5,$GET(Y(0,0))_" OK?"
+6 SET %=1
DO YN^DICN
if "-12"[%
QUIT
+7 WRITE " Confirm that this is the correct patient."
End DoDot:1
if "-12"[%
QUIT
+8 if %=-1&('$GET(QANFLAG))
DO DEL^QANCDNT
if QANXIT!(QANOUT)
QUIT
+9 IF %=-1
IF ($GET(QANFLAG))
SET QANXIT=1
QUIT
+10 IF %=2
WRITE " ??"
GOTO PAT
+11 DO PRIOR
IF QANXIT
Begin DoDot:1
+12 IF '$GET(QANFLAG)
KILL DA,DIK
SET DA=QANIEN
SET DIK="^QA(742.4,"
DO ^DIK
KILL DA,DIK
End DoDot:1
QUIT
+13 IF $DATA(^UTILITY($JOB,"QAN PAT",+Y))
WRITE !!,$CHAR(7),$PIECE(^DPT(+Y,0),U)_" has been previously entered for this incident."
KILL Y
GOTO PAT
+14 IF $DATA(^DPT(+Y,.35))
IF $PIECE(^DPT(+Y,.35),U)]""
IF ($PIECE(^DPT(+Y,.35),U)<$PIECE(^QA(742.4,QANIEN,0),U,3))
WRITE !!,$CHAR(7),"The date of death for patient: "_$PIECE(^DPT(+Y,0),U)_" precedes the incident date."
KILL Y
GOTO PAT
+15 IF $GET(QANXIT)!($GET(QANOUT))
DO DEL
QUIT
+16 SET QANPIEN=+Y
SET QANZERO=Y(0)
SET QANAME=Y(0,0)
SET QANSSN=$PIECE(QANZERO,U,9)
SET ^UTILITY($JOB,"QAN PAT",+Y)=""
+17 SET QANDOB=$PIECE(^DPT(QANPIEN,0),U,3)
+18 IF QANDOB]""
SET X=DT
SET X1=X
SET X2=QANDOB
SET X=""
if X2
DO ^%DTC
SET X=X\365.25
SET QANAGE=X
+19 SET QANPSDO(0)=Y(0)
SET QANPSDO(0,0)=Y(0,0)
+20 SET QANPID=$$QANPID(.Y)
+21 DO ADMDT^QANUTL1
+22 KILL DIC,DD,DO,DINUM,DLAYGO
SET DLAYGO=742
SET DIC="^QA(742,"
SET DIC(0)="L"
SET X=QANPIEN
DO FILE^DICN
KILL DIC,DD,DO,DINUM,DLAYGO
+23 IF +Y=-1
IF ('$GET(QANFLAG))
DO DEL
QUIT
+24 ;Something is wrong, exit.
IF +Y=-1
IF ($GET(QANFLAG))
SET QANXIT=1
QUIT
+25 SET QANDFN=+Y
+26 LOCK +^QA(742,QANDFN):10
IF '$TEST
WRITE !!,"Another user is editing this patient incident."
QUIT
+27 SET $PIECE(^QA(742,QANDFN,0),U,2,6)=QANPID_U_QANIEN_U_QANADMDT_U_QANINPAT_U_QANWARD
+28 SET $PIECE(^QA(742,QANDFN,0),U,7)=QANTRSP
SET $PIECE(^QA(742,QANDFN,0),U,12)=1
+29 SET DIK="^QA(742,"
SET DA=QANDFN
DO IX1^DIK
KILL DA,DIK
+30 LOCK -^QA(742,QANDFN)
+31 ;D:'$D(QANF) BULL^QANUTL3
SET QANFLAG=1
+32 KILL QAUDIT
SET QAUDIT("FILE")="742^50"
SET QAUDIT("DA")=QANDFN
SET QAUDIT("ACTION")="o"
SET QAUDIT("COMMENT")="Open a patient record"
DO ^QAQAUDIT
+33 QUIT
PRIOR ;
+1 SET QANTST(1)=$GET(^QA(742.4,QANIEN,0))
+2 SET QANTST("INC")=$PIECE(QANTST(1),U,2)
SET QANTST("DATE")=$PIECE(QANTST(1),U,3)
+3 FOR QAN99=0:0
SET QAN99=$ORDER(^QA(742,"AA",+Y,QAN99))
if QAN99'>0!(QANXIT)
QUIT
SET QANPRS=+$ORDER(^QA(742,"AA",+Y,QAN99,""))
IF QANPRS>0
IF ($PIECE(^QA(742,QANPRS,0),U,12)'<0)
SET QANTST(2)=$GET(^QA(742.4,QAN99,0))
DO PRIOR1
+4 KILL QAN99,QANPRS,QANTST
+5 QUIT
PRIOR1 ;
+1 IF (QANTST("INC")=$PIECE(QANTST(2),U,2))
IF (QANTST("DATE")=$PIECE(QANTST(2),U,3))
Begin DoDot:1
+2 WRITE !!,$CHAR(7),"Patient "_$PIECE(^DPT(+Y,0),U)_" has a duplicate incident on record."
+3 if '$GET(QANFLAG)
WRITE !,"Deleting the incident."
+4 if '$GET(QANFLAG)
SET QANXIT=1
+5 if $GET(QANFLAG)
WRITE !,"Please select new patient or press 'RETURN'!"
End DoDot:1
+6 ; . W:$G(QANFLAG) !,"Exiting!"
+7 ; . S QANXIT=1
+8 QUIT
DISP ;display to user what has been entered and ask if it is okay
+1 NEW QANCC,QANEE
+2 WRITE @IOF
+3 SET QAN74240=^QA(742.4,QANIEN,0)
+4 WRITE !!!,"Incident Report: "_$PIECE(QAN74240,U)
+5 SET Y=$PIECE(QAN74240,U,3)
DO DD^%DT
+6 WRITE ?35,"Date of Incident: "_Y
+7 WRITE !,"Patient: "
+8 SET QANCC=0
FOR
SET QANCC=$ORDER(^QA(742,"BCS",QANIEN,QANCC))
if QANCC'>0
QUIT
Begin DoDot:1
+9 WRITE ?10,$PIECE(^DPT($PIECE(^QA(742,QANCC,0),U),0),U),!
End DoDot:1
+10 WRITE !,"Incident Type: "
+11 IF $PIECE(QAN74240,U,2)]""
WRITE $PIECE(^QA(742.1,$PIECE(QAN74240,U,2),0),U)
+12 WRITE !,"Incident Location: "
+13 IF $PIECE(QAN74240,U,4)]""
WRITE $PIECE(^QA(742.5,$PIECE(QAN74240,U,4),0),U)
+14 WRITE !,"Was the Incident Witnessed?: "_$SELECT($PIECE(QAN74240,U,7)=1:"Yes",$PIECE(QAN74240,U,7)=0:"No",1:"")
+15 WRITE !,"Incident Description: "
+16 SET QANEE=0
FOR
SET QANEE=$ORDER(^QA(742.4,QANIEN,1,QANEE))
if QANEE'>0
QUIT
Begin DoDot:1
+17 WRITE !?3,^QA(742.4,QANIEN,1,QANEE,0)
End DoDot:1
+18 WRITE !!
+19 SET DIR("A")="Is this information correct?"
+20 SET DIR("B")="Yes"
+21 SET DIR("?")="Enter 'Yes' or 'No'."
+22 SET DIR(0)="YAO"
+23 SET DIR("?",1)="Enter 'Yes' if the information displayed is correct."
+24 SET DIR("?",2)="Enter 'No' if you need to edit this information."
+25 DO ^DIR
GOEDIT ;
+1 ;if info is not right, use code from QANEDIT to edit just the fields
+2 ;in a brief incident. There must be at least one patient/report.
+3 IF Y=0
SET QANOUT=0
Begin DoDot:1
+4 DO DIE^QANEDIT
+5 IF $ORDER(^QA(742,"BCS",QANIEN,0))']""
Begin DoDot:2
+6 WRITE !!,"No patients on this Incident Report - deleting Report."
+7 SET DIK="^QA(742.4,"
SET DA=QANIEN
DO ^DIK
KILL DIK
+8 ;also need to remove entry from QA Audit file (#740.5)
+9 ;get most recent entry for 742 and 742.4 and if matches
+10 ;this entry, delete
+11 FOR QANFILE=742,742.4
DO DIKAUDIT^QANEDIT(QANFILE)
KILL QANFILE
End DoDot:2
End DoDot:1
+12 IF $GET(^QA(742.4,QANIEN,0))]""
Begin DoDot:1
+13 ;transmit message to local mail group
DO ^QANBRIF
+14 SET QANCC=0
+15 FOR
SET QANCC=$ORDER(^QA(742,"BCS",QANIEN,QANCC))
if QANCC'>0
QUIT
Begin DoDot:2
+16 SET QANPTNUM=$PIECE(^QA(742,QANCC,0),U)
+17 SET QANODE=^DPT(QANPTNUM,0)
+18 SET QANAME=$PIECE(QANODE,U)
+19 SET QANSSN=$PIECE(QANODE,U,9)
+20 if '$DATA(QANF)
DO BULL^QANUTL3
End DoDot:2
End DoDot:1
QANPID(Y) ;Function to set up Patient ID.
+1 NEW QANF,QANM,QANL
+2 SET QANL=$PIECE(Y(0,0),",")
+3 IF QANL[" "
Begin DoDot:1
+4 SET QANF=$EXTRACT($PIECE(Y(0,0),",",2))
+5 SET QANM=$EXTRACT($PIECE(Y(0,0)," ",3))
+6 SET QANPID=$GET(QANF)_$GET(QANM)_$EXTRACT(QANL)_$EXTRACT(QANSSN,6,9)
End DoDot:1
+7 IF QANL'[" "
Begin DoDot:1
+8 SET QANF=$EXTRACT($PIECE(Y(0,0),",",2))
+9 SET QANM=$EXTRACT($PIECE(Y(0,0)," ",2))
+10 SET QANPID=$GET(QANF)_$GET(QANM)_$EXTRACT(QANL)_$EXTRACT(QANSSN,6,9)
End DoDot:1
+11 QUIT QANPID
+12 QUIT
