QANRPT2 ;HISC/GJC-SUMMARY OF INCIDENTS FOR OUTPATIENTS ;5/6/91
;;2.0;Incident Reporting;**26,29**;08/07/1992
;
S PAGE=0
;D DIV^QANRPT1
;DON'T FORGET QAQDATE FOR AD HOC REPORTS!
D ^QAQDATE I QAQQUIT D K^QAQDATE W !!,$C(7),"Invalid date range, no report will be produced." D KILL Q
S QAQNBEG(0)=QAQNBEG-.00000001,QAQNEND(0)=QAQNEND_".99999999"
S (PAGE,QANTYPE,QANTINC)=0
S QANHEAD(0)="QUALITY MANAGEMENT INCIDENT REPORT",QANHEAD(1)="SUMMARY OF INCIDENTS FOR OUTPATIENTS."
S Y=$P(QAQNBEG,".") D DD^%DT S QANDATE(0)=Y
S Y=$P(QAQNEND,".") D DD^%DT S QANDATE(1)=Y
D DIV^QANRPT1
S QANHEAD(3)="FOR THE PERIOD "_QANDATE(0)_" TO "_QANDATE(1)
;F QAN=0:0 S QAN=$O(^QA(742.4,QAN)) Q:QAN'>0 S QANZER0=$G(^QA(742.4,QAN,0)) I QANZER0]"",($P(QANZER0,U,8)'=2) S QANDATE=$P(QANZER0,U,3) I QANDATE'<QAQNBEG(0),(QANDATE'>QAQNEND(0)) S ^UTILITY($J,"QAN DATE",QAN)=""
LOOP ;loop through the date x-ref for records in the date range
N QANCC,QANDD,QANEE
S QANEE=QAQNBEG(0)
F S QANEE=$O(^QA(742.4,"BDT",QANEE)) Q:QANEE'>0!(QANEE>QAQNEND(0)) D
. S QANCC=0
. F S QANCC=$O(^QA(742.4,"BDT",QANEE,QANCC)) Q:QANCC'>0 D
. . S QANDD=0
. . F S QANDD=$O(^QA(742,"BCS",QANCC,QANDD)) Q:QANDD'>0 D
. . . Q:$P(^QA(742,QANDD,0),U,5)'=0
. . . S QANIEN=QANCC Q:QANIEN'>0
. . . S QANZER0=^QA(742.4,QANIEN,0)
. . . Q:$P(QANZER0,U,8)=2
. . . S QANDIV=$P(QANZER0,U,22) I $G(QANDIV)']"" S QANDIV=0
. . . I $G(QAN1DIV)]"" Q:QAN1DIV'=QANDIV
. . . I '$D(^QA(740,1,"QAN2","B",QANDIV)) S QANDIV=0
. . . I $P($G(^QA(740,1,"QAN")),U,5)'=1 S QANDIV=0
. . . S QANINC=$P(QANZER0,U,2) Q:$G(QANINC)'>0
. . . S ^TMP("QANRPT2",$J,"QAN",QANDIV,QANINC,QANIEN,QANDD)=""
I '$D(^TMP("QANRPT2",$J)) W !!,$C(7),"No records found for the selected date range." D KILL Q
D TOTAL
TASK S Y=DT X ^DD("DD") S TODAY=Y,$P(BNDRY,"-",$S(IOM=132:133,1:81))="",QANFIN=""
;*** Choose device ***
K IOP,%ZIS S %ZIS("A")="Print on device: ",%ZIS="MQ" W ! D ^%ZIS W !!
G:POP KILL
I $D(IO("Q")) S ZTRTN="STRT^QANRPT2",ZTDESC="Generate Incident reports for incidents by type." D QLOOP,^%ZTLOAD W !,$S($D(ZTSK):"Request queued!",1:"Request cancelled!"),! G EXIT
STRT U IO ;D HDR^QANAUX1
D:QANFIN'["^" PRINT ;ORD D:QANFIN'["^" FINAL
EXIT W ! D ^%ZISC,HOME^%ZIS
KILL ;Kill and quit.
D K^QAQDATE
K %,C,COUNT,D,DIC,BNDRY,LOOP,PAGE
K QAN,QANCDNT,QANFIN,QANHEAD
K QANINC0,QANINC1,QANJD,QANDATE,QANNCDT,QANWARD,QANZER0,TODAY,Y,QANTINC
K QANTYPE,QANINC,QANINCID,QANY,QANCHOS,X
K DTOUT,DIROUT,DIRUT,DUOUT
K ^TMP("QANRPT2")
Q
FINAL ;Final data summation.
D:$Y>(IOSL-6) HDR^QANAUX1 Q:QANFIN["^"
I '$G(COUNT("TOT")) W !!,"No incidents found, exiting the report." G EXIT
I $G(QANDVFLG)=1 W !!,"Total number if incidents for division "_QANDV_": "_COUNT("DIV",QANAA)
W !!,"The total number of outpatient incidents is: ",COUNT("TOT")
D HDH
Q
ORD ;
Q:'$D(QANINC0)
S (QANSUB,QANSUB(0))="" F S QANSUB=$O(QANINC0(QANSUB)) Q:QANSUB=""!(QANFIN["^") D:$Y>(IOSL-4) HDH Q:QANFIN["^" W !?17,QANSUB,?59,QANINC0(QANSUB),!
Q
TOTAL ;
;F QAN=0:0 S QAN=$O(^UTILITY($J,"QAN DATE",QAN)) Q:QAN'>0 F QAN(0)=0:0 S QAN(0)=$O(^QA(742,"BCS",QAN,QAN(0))) Q:QAN(0)'>0 D TOTAL1
N QANAA,QANBB,QANCC,QANDD
S QANAA=""
F S QANAA=$O(^TMP("QANRPT2",$J,"QAN",QANAA)) Q:QANAA']"" D
. S QANBB=0
. F S QANBB=$O(^TMP("QANRPT2",$J,"QAN",QANAA,QANBB)) Q:QANBB'>0 D
. . S QANCC=0
. . F S QANCC=$O(^TMP("QANRPT2",$J,"QAN",QANAA,QANBB,QANCC)) Q:QANCC'>0 D
. . . S QANDD=0
. . . F S QANDD=$O(^TMP("QANRPT2",$J,"QAN",QANAA,QANBB,QANCC,QANDD)) Q:QANDD'>0 D
. . . . S COUNT("INC",QANAA,QANBB)=$G(COUNT("INC",QANAA,QANBB))+1
. . . . S COUNT("TOT")=$G(COUNT("TOT"))+1
. . . . S COUNT("DIV",QANAA)=$G(COUNT("DIV",QANAA))+1
Q
TOTAL1 ;
;S QANZER0=$S($D(^QA(742.4,QAN,0))#2:^(0),1:""),QANZERO=$S($D(^QA(742,QAN(0),0))#2:^(0),1:"") Q:QANZER0']""!(QANZERO']"")
;S Y=$P(QANZER0,U,2) I Y]"" S C=$P(^DD(742.4,.02,0),U,2) D Y^DIQ S QANNCDT=Y
;I (+$P(QANZERO,U,5)=0) D TOTAL2
S (QANDD,QANOUT)=0
F S QANDD=$O(^QA(742,"BCS",QANCC,QANDD)) Q:QANDD'>0 D
. I $P(^QA(742,QANDD,0),U,5)'=0 S QANOUT=1
Q
TOTAL2 ;
S QANTINC=QANTINC+1
I $D(QANINC0(QANNCDT)) S QANINC0(QANNCDT)=QANINC0(QANNCDT)+1
E S QANINC0(QANNCDT)=1
Q
HDH ;
I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 QANFIN="^"
;Q:QANFIN["^" D HDR^QANAUX1
Q
QLOOP ;ZTSAVE for TaskMan.
F BA="^TMP(""QANRPT1"",$J,","^TMP(""QANRPT2"",$J,","BNDRY","PAGE","TODAY","QAN","QAQ*","COUNT(","QANFIN","QANHEAD(","QANCHOS","QANDVFLG" S ZTSAVE(BA)=""
Q
PRINT ;print or display data
I '$D(COUNT) G FINAL
S QANAA=""
F S QANAA=$O(^TMP("QANRPT2",$J,"QAN",QANAA)) Q:QANAA']"" D
. D INST^QANRPT1(QANAA,.QANDV)
. I $G(QANDVFLG)=1 S QANHEAD(4)="REPORT FOR DIVISION: "_QANDV
. D HDR^QANAUX1
. S QANBB=0
. F S QANBB=$O(^TMP("QANRPT2",$J,"QAN",QANAA,QANBB)) Q:QANBB'>0 D
. . S QANINCID=$P(^QA(742.1,QANBB,0),U)
. . D:$Y>(IOSL-6) HDH,HDR^QANAUX1 Q:QANFIN["^"
. . W !!?17,$E(QANINCID,1,35),?59,COUNT("INC",QANAA,QANBB)
. D HDH,FINAL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQANRPT2 5034 printed Apr 09, 2024@21:01:23 Page 2
QANRPT2 ;HISC/GJC-SUMMARY OF INCIDENTS FOR OUTPATIENTS ;5/6/91
+1 ;;2.0;Incident Reporting;**26,29**;08/07/1992
+2 ;
+3 SET PAGE=0
+4 ;D DIV^QANRPT1
+5 ;DON'T FORGET QAQDATE FOR AD HOC REPORTS!
+6 DO ^QAQDATE
IF QAQQUIT
DO K^QAQDATE
WRITE !!,$CHAR(7),"Invalid date range, no report will be produced."
DO KILL
QUIT
+7 SET QAQNBEG(0)=QAQNBEG-.00000001
SET QAQNEND(0)=QAQNEND_".99999999"
+8 SET (PAGE,QANTYPE,QANTINC)=0
+9 SET QANHEAD(0)="QUALITY MANAGEMENT INCIDENT REPORT"
SET QANHEAD(1)="SUMMARY OF INCIDENTS FOR OUTPATIENTS."
+10 SET Y=$PIECE(QAQNBEG,".")
DO DD^%DT
SET QANDATE(0)=Y
+11 SET Y=$PIECE(QAQNEND,".")
DO DD^%DT
SET QANDATE(1)=Y
+12 DO DIV^QANRPT1
+13 SET QANHEAD(3)="FOR THE PERIOD "_QANDATE(0)_" TO "_QANDATE(1)
+14 ;F QAN=0:0 S QAN=$O(^QA(742.4,QAN)) Q:QAN'>0 S QANZER0=$G(^QA(742.4,QAN,0)) I QANZER0]"",($P(QANZER0,U,8)'=2) S QANDATE=$P(QANZER0,U,3) I QANDATE'<QAQNBEG(0),(QANDATE'>QAQNEND(0)) S ^UTILITY($J,"QAN DATE",QAN)=""
LOOP ;loop through the date x-ref for records in the date range
+1 NEW QANCC,QANDD,QANEE
+2 SET QANEE=QAQNBEG(0)
+3 FOR
SET QANEE=$ORDER(^QA(742.4,"BDT",QANEE))
if QANEE'>0!(QANEE>QAQNEND(0))
QUIT
Begin DoDot:1
+4 SET QANCC=0
+5 FOR
SET QANCC=$ORDER(^QA(742.4,"BDT",QANEE,QANCC))
if QANCC'>0
QUIT
Begin DoDot:2
+6 SET QANDD=0
+7 FOR
SET QANDD=$ORDER(^QA(742,"BCS",QANCC,QANDD))
if QANDD'>0
QUIT
Begin DoDot:3
+8 if $PIECE(^QA(742,QANDD,0),U,5)'=0
QUIT
+9 SET QANIEN=QANCC
if QANIEN'>0
QUIT
+10 SET QANZER0=^QA(742.4,QANIEN,0)
+11 if $PIECE(QANZER0,U,8)=2
QUIT
+12 SET QANDIV=$PIECE(QANZER0,U,22)
IF $GET(QANDIV)']""
SET QANDIV=0
+13 IF $GET(QAN1DIV)]""
if QAN1DIV'=QANDIV
QUIT
+14 IF '$DATA(^QA(740,1,"QAN2","B",QANDIV))
SET QANDIV=0
+15 IF $PIECE($GET(^QA(740,1,"QAN")),U,5)'=1
SET QANDIV=0
+16 SET QANINC=$PIECE(QANZER0,U,2)
if $GET(QANINC)'>0
QUIT
+17 SET ^TMP("QANRPT2",$JOB,"QAN",QANDIV,QANINC,QANIEN,QANDD)=""
End DoDot:3
End DoDot:2
End DoDot:1
+18 IF '$DATA(^TMP("QANRPT2",$JOB))
WRITE !!,$CHAR(7),"No records found for the selected date range."
DO KILL
QUIT
+19 DO TOTAL
TASK SET Y=DT
XECUTE ^DD("DD")
SET TODAY=Y
SET $PIECE(BNDRY,"-",$SELECT(IOM=132:133,1:81))=""
SET QANFIN=""
+1 ;*** Choose device ***
+2 KILL IOP,%ZIS
SET %ZIS("A")="Print on device: "
SET %ZIS="MQ"
WRITE !
DO ^%ZIS
WRITE !!
+3 if POP
GOTO KILL
+4 IF $DATA(IO("Q"))
SET ZTRTN="STRT^QANRPT2"
SET ZTDESC="Generate Incident reports for incidents by type."
DO QLOOP
DO ^%ZTLOAD
WRITE !,$SELECT($DATA(ZTSK):"Request queued!",1:"Request cancelled!"),!
GOTO EXIT
STRT ;D HDR^QANAUX1
USE IO
+1 ;ORD D:QANFIN'["^" FINAL
if QANFIN'["^"
DO PRINT
EXIT WRITE !
DO ^%ZISC
DO HOME^%ZIS
KILL ;Kill and quit.
+1 DO K^QAQDATE
+2 KILL %,C,COUNT,D,DIC,BNDRY,LOOP,PAGE
+3 KILL QAN,QANCDNT,QANFIN,QANHEAD
+4 KILL QANINC0,QANINC1,QANJD,QANDATE,QANNCDT,QANWARD,QANZER0,TODAY,Y,QANTINC
+5 KILL QANTYPE,QANINC,QANINCID,QANY,QANCHOS,X
+6 KILL DTOUT,DIROUT,DIRUT,DUOUT
+7 KILL ^TMP("QANRPT2")
+8 QUIT
FINAL ;Final data summation.
+1 if $Y>(IOSL-6)
DO HDR^QANAUX1
if QANFIN["^"
QUIT
+2 IF '$GET(COUNT("TOT"))
WRITE !!,"No incidents found, exiting the report."
GOTO EXIT
+3 IF $GET(QANDVFLG)=1
WRITE !!,"Total number if incidents for division "_QANDV_": "_COUNT("DIV",QANAA)
+4 WRITE !!,"The total number of outpatient incidents is: ",COUNT("TOT")
+5 DO HDH
+6 QUIT
ORD ;
+1 if '$DATA(QANINC0)
QUIT
+2 SET (QANSUB,QANSUB(0))=""
FOR
SET QANSUB=$ORDER(QANINC0(QANSUB))
if QANSUB=""!(QANFIN["^")
QUIT
if $Y>(IOSL-4)
DO HDH
if QANFIN["^"
QUIT
WRITE !?17,QANSUB,?59,QANINC0(QANSUB),!
+3 QUIT
TOTAL ;
+1 ;F QAN=0:0 S QAN=$O(^UTILITY($J,"QAN DATE",QAN)) Q:QAN'>0 F QAN(0)=0:0 S QAN(0)=$O(^QA(742,"BCS",QAN,QAN(0))) Q:QAN(0)'>0 D TOTAL1
+2 NEW QANAA,QANBB,QANCC,QANDD
+3 SET QANAA=""
+4 FOR
SET QANAA=$ORDER(^TMP("QANRPT2",$JOB,"QAN",QANAA))
if QANAA']""
QUIT
Begin DoDot:1
+5 SET QANBB=0
+6 FOR
SET QANBB=$ORDER(^TMP("QANRPT2",$JOB,"QAN",QANAA,QANBB))
if QANBB'>0
QUIT
Begin DoDot:2
+7 SET QANCC=0
+8 FOR
SET QANCC=$ORDER(^TMP("QANRPT2",$JOB,"QAN",QANAA,QANBB,QANCC))
if QANCC'>0
QUIT
Begin DoDot:3
+9 SET QANDD=0
+10 FOR
SET QANDD=$ORDER(^TMP("QANRPT2",$JOB,"QAN",QANAA,QANBB,QANCC,QANDD))
if QANDD'>0
QUIT
Begin DoDot:4
+11 SET COUNT("INC",QANAA,QANBB)=$GET(COUNT("INC",QANAA,QANBB))+1
+12 SET COUNT("TOT")=$GET(COUNT("TOT"))+1
+13 SET COUNT("DIV",QANAA)=$GET(COUNT("DIV",QANAA))+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
TOTAL1 ;
+1 ;S QANZER0=$S($D(^QA(742.4,QAN,0))#2:^(0),1:""),QANZERO=$S($D(^QA(742,QAN(0),0))#2:^(0),1:"") Q:QANZER0']""!(QANZERO']"")
+2 ;S Y=$P(QANZER0,U,2) I Y]"" S C=$P(^DD(742.4,.02,0),U,2) D Y^DIQ S QANNCDT=Y
+3 ;I (+$P(QANZERO,U,5)=0) D TOTAL2
+4 SET (QANDD,QANOUT)=0
+5 FOR
SET QANDD=$ORDER(^QA(742,"BCS",QANCC,QANDD))
if QANDD'>0
QUIT
Begin DoDot:1
+6 IF $PIECE(^QA(742,QANDD,0),U,5)'=0
SET QANOUT=1
End DoDot:1
+7 QUIT
TOTAL2 ;
+1 SET QANTINC=QANTINC+1
+2 IF $DATA(QANINC0(QANNCDT))
SET QANINC0(QANNCDT)=QANINC0(QANNCDT)+1
+3 IF '$TEST
SET QANINC0(QANNCDT)=1
+4 QUIT
HDH ;
+1 IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
if +Y=0
SET QANFIN="^"
+2 ;Q:QANFIN["^" D HDR^QANAUX1
+3 QUIT
QLOOP ;ZTSAVE for TaskMan.
+1 FOR BA="^TMP(""QANRPT1"",$J,","^TMP(""QANRPT2"",$J,","BNDRY","PAGE","TODAY","QAN","QAQ*","COUNT(","QANFIN","QANHEAD(","QANCHOS","QANDVFLG"
SET ZTSAVE(BA)=""
+2 QUIT
PRINT ;print or display data
+1 IF '$DATA(COUNT)
GOTO FINAL
+2 SET QANAA=""
+3 FOR
SET QANAA=$ORDER(^TMP("QANRPT2",$JOB,"QAN",QANAA))
if QANAA']""
QUIT
Begin DoDot:1
+4 DO INST^QANRPT1(QANAA,.QANDV)
+5 IF $GET(QANDVFLG)=1
SET QANHEAD(4)="REPORT FOR DIVISION: "_QANDV
+6 DO HDR^QANAUX1
+7 SET QANBB=0
+8 FOR
SET QANBB=$ORDER(^TMP("QANRPT2",$JOB,"QAN",QANAA,QANBB))
if QANBB'>0
QUIT
Begin DoDot:2
+9 SET QANINCID=$PIECE(^QA(742.1,QANBB,0),U)
+10 if $Y>(IOSL-6)
DO HDH
DO HDR^QANAUX1
if QANFIN["^"
QUIT
+11 WRITE !!?17,$EXTRACT(QANINCID,1,35),?59,COUNT("INC",QANAA,QANBB)
End DoDot:2
+12 DO HDH
DO FINAL
End DoDot:1
+13 QUIT
