QAOSPPR0 ;HISC/DAD-PEER REVIEWER WORKSHEET ;2/16/93 09:31
;;3.0;Occurrence Screen;;09/14/1993
S QAOSSCRN=+$G(^QA(741,QAOSD0,"SCRN")),QAOSPEER=$O(^QA(741.2,"C",2,0)),QAOSREVR=2,QAOSQUIT=0
I QAOSDATA=1 S QAOSD1="" D LOOP1 W:$E(IOST)'="C" @IOF D G EXIT
. Q:$E(IOST)'="C" Q:QAOSQUIT
. K DIR S DIR(0)="E" D ^DIR K DIR
. S QAOSQUIT=$S(Y'>0:1,1:0)
. Q
I QAOSDATA=2,'$D(^QA(741,QAOSD0,"REVR","B",QAOSPEER)) S QAOSD1="" D LOOP1 W:$E(IOST)'="C" @IOF D G EXIT
. Q:$E(IOST)'="C" Q:QAOSQUIT
. K DIR S DIR(0)="E" D ^DIR K DIR
. S QAOSQUIT=$S(Y'>0:1,1:0)
. Q
F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"REVR","B",QAOSPEER,QAOSD1)) Q:QAOSD1'>0!QAOSQUIT D LOOP1 W:$E(IOST)'="C" @IOF I ('QAOSQUIT),$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S QAOSQUIT=$S(Y'>0:1,1:0) Q:QAOSQUIT
EXIT ;
K ARRAY,D0,DIWF,DIWL,DIWR,LOC,QA,QAOSD1,QAOSHEAD,QAOSMULT,QAOSPAGE,QAOSREVR,QAOSSCRN,QAOSPEER,X,XX,Y
Q
LOOP1 ;
S QAOSMULT=$S(QAOSD1'>0:"",$D(^QA(741,QAOSD0,"REVR",QAOSD1,0))#2:^(0),1:"")
S QA=$P(QAOSMULT,"^",2) S $P(QAOSREVR,"^",2)=$S(QA'>0:"",$D(^VA(200,QA,0))#2:$P(^(0),"^"),1:"")
S QAOSPAGE=1 D ^QAOSPHDR
S QAOSHEAD="FINDINGS" W !!,QAOSHEAD
F QA=0:0 S QA=$O(^QA(741.6,"B",QA)) Q:QA'>0!QAOSQUIT F D0=0:0 S D0=$O(^QA(741.6,"B",QA,D0)) Q:D0'>0!QAOSQUIT S LOC=^QA(741.6,D0,0) I $P(LOC,"^",3)["2" W !?3,$S($P(QAOSMULT,"^",5)=D0:"_X_",1:"___"),?8,$J(QA,3,0),?15,$P(LOC,"^",2) D CHK
Q:QAOSQUIT
W !!,"If quality of care is rated as level 2 or 3, indicate involved practitioner(s).",!!," __________________________________________________________________________" S QAOSHEAD="" D CHK Q:QAOSQUIT
K ARRAY
F QA=0:0 S QA=$O(^QA(741.7,"B",QA)) Q:QA'>0 F D0=0:0 S D0=$O(^QA(741.7,"B",QA,D0)) Q:D0'>0 S LOC=^QA(741.7,D0,0) I $P(LOC,"^",2)["2" S ARRAY(+LOC)=$S(QAOSD1'>0:"___",$D(^QA(741,QAOSD0,"REVR",QAOSD1,2,"B",D0)):"_X_",1:"___")_"^"_$P(LOC,"^",3)
S QAOSHEAD="ACTION(S)" W !!,QAOSHEAD F QA=0:0 S QA=$O(ARRAY(QA)) Q:QA'>0!QAOSQUIT W !?3,$P(ARRAY(QA),"^"),?8,$J(QA,3,0),?15,$P(ARRAY(QA),"^",2) D CHK
Q:QAOSQUIT
S QAOSHEAD="SEVERITY OF OUTCOME" W !!,QAOSHEAD
S LOC=$S(QAOSHOW=3!(QAOSDATA=1):"",1:$P($G(^QA(741,QAOSD0,0)),"^",18))
F QA=-1:0 S QA=$O(^QA(741.8,"B",QA)) Q:QA=""!QAOSQUIT F D0=0:0 S D0=$O(^QA(741.8,"B",QA,D0)) Q:D0'>0!QAOSQUIT W !?3,$S(D0=LOC:"_X_",1:"___"),?8,$J(QA,3,0),?15,$P(^QA(741.8,D0,0),"^",2) D CHK
Q:QAOSQUIT
W !!,"DATE REVIEW COMPLETED: " S Y=$P(QAOSMULT,"^",3) X ^DD("DD") W $S(Y]"":Y,1:"____________________")
S QAOSPDUE=$P($G(^QA(741,QAOSD0,0)),"^",12),QAOSPDAY=$P($G(^QA(740,1,"OS")),"^") I QAOSPDUE!QAOSPDAY D
. S Y=QAOSPDUE X ^DD("DD") W ?47,"DUE DATE: "
. W $S((QAOSHOW=3)!(QAOSDATA=1)!(Y=""):"____________________",1:Y)
. Q
D CHK Q:QAOSQUIT
S QAOSHEAD="" W !!,"Can steps be taken to improve the care of similar patients in the future?" D CHK Q:QAOSQUIT
W !,"___ YES, ___ NO. If YES, describe. (Please answer even if quality of" D CHK W !,"care was rated as ""LEVEL 1"".)" D CHK Q:QAOSQUIT
S QAOSHEAD="" W !!,"Should the care in this case be considered for educational presentations" D CHK Q:QAOSQUIT
W !,"because it was exemplary? ___ YES, ___ NO. If YES, describe." D CHK Q:QAOSQUIT
S QAOSHEAD="COMMENTS" W !!,QAOSHEAD S DIWL=4,DIWR=75,DIWF="" K ^UTILITY($J,"W")
I QAOSHOW'=3,QAOSDATA=2 F QAOSS0=0:0 S QAOSS0=$O(^QA(741,QAOSD0,"REVR",+QAOSD1,3,QAOSS0)) Q:QAOSS0'>0 S X=^QA(741,QAOSD0,"REVR",QAOSD1,3,QAOSS0,0) D ^DIWP
F QA=0:0 S QA=$O(^UTILITY($J,"W",DIWL,QA)) Q:QA'>0!QAOSQUIT W !?3,^UTILITY($J,"W",DIWL,QA,0) D CHK
Q:QAOSQUIT
BLANK I $Y<(IOSL-6) W ! G BLANK
W !,"SIGNATURE"
Q
CHK ;
Q:$Y'>(IOSL-6) N D0,QA,Y I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S QAOSQUIT=$S(Y'>0:1,1:0) Q:QAOSQUIT
D ^QAOSPHDR W !!,QAOSHEAD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSPPR0 3732 printed Apr 09, 2024@21:23:29 Page 2
QAOSPPR0 ;HISC/DAD-PEER REVIEWER WORKSHEET ;2/16/93 09:31
+1 ;;3.0;Occurrence Screen;;09/14/1993
+2 SET QAOSSCRN=+$GET(^QA(741,QAOSD0,"SCRN"))
SET QAOSPEER=$ORDER(^QA(741.2,"C",2,0))
SET QAOSREVR=2
SET QAOSQUIT=0
+3 IF QAOSDATA=1
SET QAOSD1=""
DO LOOP1
if $EXTRACT(IOST)'="C"
WRITE @IOF
Begin DoDot:1
+4 if $EXTRACT(IOST)'="C"
QUIT
if QAOSQUIT
QUIT
+5 KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
+6 SET QAOSQUIT=$SELECT(Y'>0:1,1:0)
+7 QUIT
End DoDot:1
GOTO EXIT
+8 IF QAOSDATA=2
IF '$DATA(^QA(741,QAOSD0,"REVR","B",QAOSPEER))
SET QAOSD1=""
DO LOOP1
if $EXTRACT(IOST)'="C"
WRITE @IOF
Begin DoDot:1
+9 if $EXTRACT(IOST)'="C"
QUIT
if QAOSQUIT
QUIT
+10 KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
+11 SET QAOSQUIT=$SELECT(Y'>0:1,1:0)
+12 QUIT
End DoDot:1
GOTO EXIT
+13 FOR QAOSD1=0:0
SET QAOSD1=$ORDER(^QA(741,QAOSD0,"REVR","B",QAOSPEER,QAOSD1))
if QAOSD1'>0!QAOSQUIT
QUIT
DO LOOP1
if $EXTRACT(IOST)'="C"
WRITE @IOF
IF ('QAOSQUIT)
IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
SET QAOSQUIT=$SELECT(Y'>0:1,1:0)
if QAOSQUIT
QUIT
EXIT ;
+1 KILL ARRAY,D0,DIWF,DIWL,DIWR,LOC,QA,QAOSD1,QAOSHEAD,QAOSMULT,QAOSPAGE,QAOSREVR,QAOSSCRN,QAOSPEER,X,XX,Y
+2 QUIT
LOOP1 ;
+1 SET QAOSMULT=$SELECT(QAOSD1'>0:"",$DATA(^QA(741,QAOSD0,"REVR",QAOSD1,0))#2:^(0),1:"")
+2 SET QA=$PIECE(QAOSMULT,"^",2)
SET $PIECE(QAOSREVR,"^",2)=$SELECT(QA'>0:"",$DATA(^VA(200,QA,0))#2:$PIECE(^(0),"^"),1:"")
+3 SET QAOSPAGE=1
DO ^QAOSPHDR
+4 SET QAOSHEAD="FINDINGS"
WRITE !!,QAOSHEAD
+5 FOR QA=0:0
SET QA=$ORDER(^QA(741.6,"B",QA))
if QA'>0!QAOSQUIT
QUIT
FOR D0=0:0
SET D0=$ORDER(^QA(741.6,"B",QA,D0))
if D0'>0!QAOSQUIT
QUIT
SET LOC=^QA(741.6,D0,0)
IF $PIECE(LOC,"^",3)["2"
WRITE !?3,$SELECT($PIECE(QAOSMULT,"^",5)=D0:"_X_",1:"___"),?8,$JUSTIFY(QA,3,0),?15,$PIECE(LOC,"^",2)
DO CHK
+6 if QAOSQUIT
QUIT
+7 WRITE !!,"If quality of care is rated as level 2 or 3, indicate involved practitioner(s).",!!," __________________________________________________________________________"
SET QAOSHEAD=""
DO CHK
if QAOSQUIT
QUIT
+8 KILL ARRAY
+9 FOR QA=0:0
SET QA=$ORDER(^QA(741.7,"B",QA))
if QA'>0
QUIT
FOR D0=0:0
SET D0=$ORDER(^QA(741.7,"B",QA,D0))
if D0'>0
QUIT
SET LOC=^QA(741.7,D0,0)
IF $PIECE(LOC,"^",2)["2"
SET ARRAY(+LOC)=$SELECT(QAOSD1'>0:"___",$DATA(^QA(741,QAOSD0,"REVR",QAOSD1,2,"B",D0)):"_X_",1:"___")_"^"_$PIECE(LOC,"^",3)
+10 SET QAOSHEAD="ACTION(S)"
WRITE !!,QAOSHEAD
FOR QA=0:0
SET QA=$ORDER(ARRAY(QA))
if QA'>0!QAOSQUIT
QUIT
WRITE !?3,$PIECE(ARRAY(QA),"^"),?8,$JUSTIFY(QA,3,0),?15,$PIECE(ARRAY(QA),"^",2)
DO CHK
+11 if QAOSQUIT
QUIT
+12 SET QAOSHEAD="SEVERITY OF OUTCOME"
WRITE !!,QAOSHEAD
+13 SET LOC=$SELECT(QAOSHOW=3!(QAOSDATA=1):"",1:$PIECE($GET(^QA(741,QAOSD0,0)),"^",18))
+14 FOR QA=-1:0
SET QA=$ORDER(^QA(741.8,"B",QA))
if QA=""!QAOSQUIT
QUIT
FOR D0=0:0
SET D0=$ORDER(^QA(741.8,"B",QA,D0))
if D0'>0!QAOSQUIT
QUIT
WRITE !?3,$SELECT(D0=LOC:"_X_",1:"___"),?8,$JUSTIFY(QA,3,0),?15,$PIECE(^QA(741.8,D0,0),"^",2)
DO CHK
+15 if QAOSQUIT
QUIT
+16 WRITE !!,"DATE REVIEW COMPLETED: "
SET Y=$PIECE(QAOSMULT,"^",3)
XECUTE ^DD("DD")
WRITE $SELECT(Y]"":Y,1:"____________________")
+17 SET QAOSPDUE=$PIECE($GET(^QA(741,QAOSD0,0)),"^",12)
SET QAOSPDAY=$PIECE($GET(^QA(740,1,"OS")),"^")
IF QAOSPDUE!QAOSPDAY
Begin DoDot:1
+18 SET Y=QAOSPDUE
XECUTE ^DD("DD")
WRITE ?47,"DUE DATE: "
+19 WRITE $SELECT((QAOSHOW=3)!(QAOSDATA=1)!(Y=""):"____________________",1:Y)
+20 QUIT
End DoDot:1
+21 DO CHK
if QAOSQUIT
QUIT
+22 SET QAOSHEAD=""
WRITE !!,"Can steps be taken to improve the care of similar patients in the future?"
DO CHK
if QAOSQUIT
QUIT
+23 WRITE !,"___ YES, ___ NO. If YES, describe. (Please answer even if quality of"
DO CHK
WRITE !,"care was rated as ""LEVEL 1"".)"
DO CHK
if QAOSQUIT
QUIT
+24 SET QAOSHEAD=""
WRITE !!,"Should the care in this case be considered for educational presentations"
DO CHK
if QAOSQUIT
QUIT
+25 WRITE !,"because it was exemplary? ___ YES, ___ NO. If YES, describe."
DO CHK
if QAOSQUIT
QUIT
+26 SET QAOSHEAD="COMMENTS"
WRITE !!,QAOSHEAD
SET DIWL=4
SET DIWR=75
SET DIWF=""
KILL ^UTILITY($JOB,"W")
+27 IF QAOSHOW'=3
IF QAOSDATA=2
FOR QAOSS0=0:0
SET QAOSS0=$ORDER(^QA(741,QAOSD0,"REVR",+QAOSD1,3,QAOSS0))
if QAOSS0'>0
QUIT
SET X=^QA(741,QAOSD0,"REVR",QAOSD1,3,QAOSS0,0)
DO ^DIWP
+28 FOR QA=0:0
SET QA=$ORDER(^UTILITY($JOB,"W",DIWL,QA))
if QA'>0!QAOSQUIT
QUIT
WRITE !?3,^UTILITY($JOB,"W",DIWL,QA,0)
DO CHK
+29 if QAOSQUIT
QUIT
BLANK IF $Y<(IOSL-6)
WRITE !
GOTO BLANK
+1 WRITE !,"SIGNATURE"
+2 QUIT
CHK ;
+1 if $Y'>(IOSL-6)
QUIT
NEW D0,QA,Y
IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
SET QAOSQUIT=$SELECT(Y'>0:1,1:0)
if QAOSQUIT
QUIT
+2 DO ^QAOSPHDR
WRITE !!,QAOSHEAD
+3 QUIT
