QANCNVT ;HISC/GJC,DAD-Conversion of incident type from V1.01 TO V2.0 ;10/9/92
;;2.0;Incident Reporting;**1,2,4,5,18**;08/07/1992
EN1 ; Passed in variable 'PRMQINC' *** old incident code (.01 of 513.941)
D KILL K QANINCD S QANFLG=0
F QAN=1:1 S QA("NEW NAME")=$P($T(TYPTXT+QAN),";;",2),QA("OLD CODES")=$P($T(TYPTXT+QAN),";;",3) Q:QA("NEW NAME")']"" D CHKNME Q:QANFLG
D:'QANFLG CONVERT
I QANXIT W !!,*7,"Error in converting incident types for file 742.1.",!,"Contact your site manager.",*7 S $P(^PRMQ(513.72,PRMQIEN,0),U,3)=1
KILL ;
K QANCT,QANCNT,QANVV,QANXX,QANZZ
Q
CHKNME ;Piece off 'old' incident codes.
F QANCNT=1:1:$L(QA("OLD CODES"),U) S QA("OLD CODE")=$P(QA("OLD CODES"),U,QANCNT) I QA("OLD CODE")=PRMQINC D
. I $D(^QA(742.1,"BUPPER",QA("NEW NAME"))) S QANINCD=$O(^QA(742.1,"BUPPER",QA("NEW NAME"),0))
S:+$G(QANINCD) QANFLG=1
Q
CONVERT ;Convert 'old' incident into a 'new' one.
I $D(^PRMQ(513.941,"B",PRMQINC)) S PRMQINC(0)=$O(^PRMQ(513.941,"B",PRMQINC,0))
I +$G(PRMQINC(0)) S PRMQINC(1)=$P($G(^PRMQ(513.941,PRMQINC(0),0)),U,2) D:PRMQINC(1)]""
. I $D(^QA(742.1,"B",PRMQINC(1))) S QANINCD=$O(^QA(742.1,"B",PRMQINC(1),0)) Q ;Exists, quit
. F QAN=199.99:0 S QAN=$O(^QA(742.1,QAN)) Q:QAN'>0 S QAN("LAST")=QAN
. K DA,DD,DIC,DINUM,DLAYGO,DO
. S DINUM=$S('$D(QAN("LAST")):200,1:(QAN("LAST")+.01)) S:DINUM>999.99 QANXIT=1 Q:QANXIT
. S DIC="^QA(742.1,",DIC(0)="LZ",X=PRMQINC(1),QANINCD=DINUM D FILE^DICN
. I +Y'>0 S QANXIT=1 Q
. S $P(^QA(742.1,+Y,0),U,6)="1"
. K DA,DD,DIC,DINUM,DLAYGO,DO,X
E S QANXIT=1
Q
PAT ;Creating an entry in file 742.
S VAINDT=QANDATE,DFN=QANPAT D INP^VADPT S QANADMDT=$P(VAIN(7),U)
K DA,DD,DIC,DINUM,DLAYGO,DO
S DIC="^QA(742,",DIC(0)="LZ",X=QANPAT D FILE^DICN
K DD,DIC,DINUM,DLAYGO,DO
I +Y'>0 W !!,*7,"Error in data conversion, contact your site manager.",*7 S $P(^PRMQ(513.72,PRMQIEN,0),U,3)=1 Q
S QANIEN(742)=+Y,QANNODE(742)=$G(^QA(742,QANIEN(742),0))
Q:QANNODE(742)']""
S $P(QANNODE(742),U,2,7)=$G(QANPID)_U_QANIEN(7424)_U_QANADMDT_U_QANPTY_U_QANWARD_U_QANTREAT
S $P(QANNODE(742),U,10)=$S(PRMQINC="111E":3,1:$G(QANSLEV))
S $P(QANNODE(742),U,12)=$S(PRMQDISP]""!($G(QANLVL(0))="CA"):0,1:1)
S ^QA(742,QANIEN(742),0)=QANNODE(742) D SVLEV
K DA,DIK S DA=QANIEN(742),DIK="^QA(742," D IX^DIK K DA,DIK ;Reindex file 742
Q
SVLEV ;Setting the responsible service multiple
Q:'$D(^TMP($J,"QAN RESPONSIBLE SERVICE"))
S:'$D(^QA(742,QANIEN(742),1,0))#2 ^QA(742,QANIEN(742),1,0)="^742.01P^^"
F QAN=0:0 S QAN=$O(^TMP($J,"QAN RESPONSIBLE SERVICE",QAN)) Q:QAN'>0 D
. K DA,DD,DIC,DINUM,DLAYGO,DO
. S DA(1)=QANIEN(742),DIC="^QA(742,"_QANIEN(742)_",1,",DIC(0)="LZ"
. S X=QAN D FILE^DICN
. K DA,DD,DIC,DINUM,DLAYGO,DO
. Q
Q
TYPTXT ; TEXT OF FILE 742.1 EQUIVALENT
;;ADVERSE REACTION TO DRUG/ANESTHETIC;;109C^111E
;;ASSAULT-PATIENT TO PATIENT;;113
;;ASSAULT-PATIENT/STAFF;;114
;;DEATH;;110^110A^111^111A^111B^111C^111D^111F^115G
;;DIAGNOSTIC ERROR;;115E
;;FALL;;106^106A
;;FIRE-PATIENT INVOLVED IN;;112
;;HOMICIDE;;104B^113B^114B^115H
;;INACCURATE COUNTS IN SURGERY;;115C
;;INFORMED CONSENT-FAIL. TO OBTAIN;;115B
;;MEDICATION ERROR;;108^108A
;;PATIENT ABUSE;;104^105
;;INJURY NOT OTHERWISE LISTED;;109A^109B^109D
;;SEXUAL ASSAULT;;104A^113A^114A
;;REACT. TO BLOOD/BLOOD PRODUCTS;;115D
;;MISSING PATIENT;;115A
;;SUICIDE;;103
;;SUICIDE ATTEMPT;;102
;;TRANSFUSION ERROR;;107
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQANCNVT 3415 printed Apr 09, 2024@21:01:53 Page 2
QANCNVT ;HISC/GJC,DAD-Conversion of incident type from V1.01 TO V2.0 ;10/9/92
+1 ;;2.0;Incident Reporting;**1,2,4,5,18**;08/07/1992
EN1 ; Passed in variable 'PRMQINC' *** old incident code (.01 of 513.941)
+1 DO KILL
KILL QANINCD
SET QANFLG=0
+2 FOR QAN=1:1
SET QA("NEW NAME")=$PIECE($TEXT(TYPTXT+QAN),";;",2)
SET QA("OLD CODES")=$PIECE($TEXT(TYPTXT+QAN),";;",3)
if QA("NEW NAME")']""
QUIT
DO CHKNME
if QANFLG
QUIT
+3 if 'QANFLG
DO CONVERT
+4 IF QANXIT
WRITE !!,*7,"Error in converting incident types for file 742.1.",!,"Contact your site manager.",*7
SET $PIECE(^PRMQ(513.72,PRMQIEN,0),U,3)=1
KILL ;
+1 KILL QANCT,QANCNT,QANVV,QANXX,QANZZ
+2 QUIT
CHKNME ;Piece off 'old' incident codes.
+1 FOR QANCNT=1:1:$LENGTH(QA("OLD CODES"),U)
SET QA("OLD CODE")=$PIECE(QA("OLD CODES"),U,QANCNT)
IF QA("OLD CODE")=PRMQINC
Begin DoDot:1
+2 IF $DATA(^QA(742.1,"BUPPER",QA("NEW NAME")))
SET QANINCD=$ORDER(^QA(742.1,"BUPPER",QA("NEW NAME"),0))
End DoDot:1
+3 if +$GET(QANINCD)
SET QANFLG=1
+4 QUIT
CONVERT ;Convert 'old' incident into a 'new' one.
+1 IF $DATA(^PRMQ(513.941,"B",PRMQINC))
SET PRMQINC(0)=$ORDER(^PRMQ(513.941,"B",PRMQINC,0))
+2 IF +$GET(PRMQINC(0))
SET PRMQINC(1)=$PIECE($GET(^PRMQ(513.941,PRMQINC(0),0)),U,2)
if PRMQINC(1)]""
Begin DoDot:1
+3 ;Exists, quit
IF $DATA(^QA(742.1,"B",PRMQINC(1)))
SET QANINCD=$ORDER(^QA(742.1,"B",PRMQINC(1),0))
QUIT
+4 FOR QAN=199.99:0
SET QAN=$ORDER(^QA(742.1,QAN))
if QAN'>0
QUIT
SET QAN("LAST")=QAN
+5 KILL DA,DD,DIC,DINUM,DLAYGO,DO
+6 SET DINUM=$SELECT('$DATA(QAN("LAST")):200,1:(QAN("LAST")+.01))
if DINUM>999.99
SET QANXIT=1
if QANXIT
QUIT
+7 SET DIC="^QA(742.1,"
SET DIC(0)="LZ"
SET X=PRMQINC(1)
SET QANINCD=DINUM
DO FILE^DICN
+8 IF +Y'>0
SET QANXIT=1
QUIT
+9 SET $PIECE(^QA(742.1,+Y,0),U,6)="1"
+10 KILL DA,DD,DIC,DINUM,DLAYGO,DO,X
End DoDot:1
+11 IF '$TEST
SET QANXIT=1
+12 QUIT
PAT ;Creating an entry in file 742.
+1 SET VAINDT=QANDATE
SET DFN=QANPAT
DO INP^VADPT
SET QANADMDT=$PIECE(VAIN(7),U)
+2 KILL DA,DD,DIC,DINUM,DLAYGO,DO
+3 SET DIC="^QA(742,"
SET DIC(0)="LZ"
SET X=QANPAT
DO FILE^DICN
+4 KILL DD,DIC,DINUM,DLAYGO,DO
+5 IF +Y'>0
WRITE !!,*7,"Error in data conversion, contact your site manager.",*7
SET $PIECE(^PRMQ(513.72,PRMQIEN,0),U,3)=1
QUIT
+6 SET QANIEN(742)=+Y
SET QANNODE(742)=$GET(^QA(742,QANIEN(742),0))
+7 if QANNODE(742)']""
QUIT
+8 SET $PIECE(QANNODE(742),U,2,7)=$GET(QANPID)_U_QANIEN(7424)_U_QANADMDT_U_QANPTY_U_QANWARD_U_QANTREAT
+9 SET $PIECE(QANNODE(742),U,10)=$SELECT(PRMQINC="111E":3,1:$GET(QANSLEV))
+10 SET $PIECE(QANNODE(742),U,12)=$SELECT(PRMQDISP]""!($GET(QANLVL(0))="CA"):0,1:1)
+11 SET ^QA(742,QANIEN(742),0)=QANNODE(742)
DO SVLEV
+12 ;Reindex file 742
KILL DA,DIK
SET DA=QANIEN(742)
SET DIK="^QA(742,"
DO IX^DIK
KILL DA,DIK
+13 QUIT
SVLEV ;Setting the responsible service multiple
+1 if '$DATA(^TMP($JOB,"QAN RESPONSIBLE SERVICE"))
QUIT
+2 if '$DATA(^QA(742,QANIEN(742),1,0))#2
SET ^QA(742,QANIEN(742),1,0)="^742.01P^^"
+3 FOR QAN=0:0
SET QAN=$ORDER(^TMP($JOB,"QAN RESPONSIBLE SERVICE",QAN))
if QAN'>0
QUIT
Begin DoDot:1
+4 KILL DA,DD,DIC,DINUM,DLAYGO,DO
+5 SET DA(1)=QANIEN(742)
SET DIC="^QA(742,"_QANIEN(742)_",1,"
SET DIC(0)="LZ"
+6 SET X=QAN
DO FILE^DICN
+7 KILL DA,DD,DIC,DINUM,DLAYGO,DO
+8 QUIT
End DoDot:1
+9 QUIT
TYPTXT ; TEXT OF FILE 742.1 EQUIVALENT
+1 ;;ADVERSE REACTION TO DRUG/ANESTHETIC;;109C^111E
+2 ;;ASSAULT-PATIENT TO PATIENT;;113
+3 ;;ASSAULT-PATIENT/STAFF;;114
+4 ;;DEATH;;110^110A^111^111A^111B^111C^111D^111F^115G
+5 ;;DIAGNOSTIC ERROR;;115E
+6 ;;FALL;;106^106A
+7 ;;FIRE-PATIENT INVOLVED IN;;112
+8 ;;HOMICIDE;;104B^113B^114B^115H
+9 ;;INACCURATE COUNTS IN SURGERY;;115C
+10 ;;INFORMED CONSENT-FAIL. TO OBTAIN;;115B
+11 ;;MEDICATION ERROR;;108^108A
+12 ;;PATIENT ABUSE;;104^105
+13 ;;INJURY NOT OTHERWISE LISTED;;109A^109B^109D
+14 ;;SEXUAL ASSAULT;;104A^113A^114A
+15 ;;REACT. TO BLOOD/BLOOD PRODUCTS;;115D
+16 ;;MISSING PATIENT;;115A
+17 ;;SUICIDE;;103
+18 ;;SUICIDE ATTEMPT;;102
+19 ;;TRANSFUSION ERROR;;107
+20 QUIT
