QAOEDT0P ;HISC/DAD-PEER REVIEW LEVEL EDIT ;2/3/93 15:57
;;3.0;Occurrence Screen;;09/14/1993
REVLEV S (QAOSQUIT,QAOSNEWF)=0,QAOSREVR(0)=+^QA(741,QAOSD0,"REVR",QAOSD1,0)
K DR S DIE="^QA(741,"_QAOSD0_",""REVR"",",DR=".01"
S (D0,DA(1))=QAOSD0,(D1,DA)=QAOSD1 D ^DIE G:('$D(DA))!($D(Y)) EXIT
S QAOSREVR(1)=+^QA(741,QAOSD0,"REVR",QAOSD1,0)
I QAOSREVR(0)'=QAOSREVR(1) D RESET^QAOEDT0 G REVLEV
K DR S DIE="^QA(741,"_QAOSD0_",""REVR"",",DR=".02T;.03"
S (D0,DA(1))=QAOSD0,(D1,DA)=QAOSD1 D ^DIE G:$D(Y) EXIT
FINDING ;
S QAOSFIND(1)=$P($G(^QA(741,QAOSD0,"REVR",QAOSD1,0)),"^",5)
K DR S DIE="^QA(741,"_QAOSD0_",""REVR"",",DR="4"
S (D0,DA(1))=QAOSD0,(D1,DA)=QAOSD1 D ^DIE G:$D(Y) EXIT
S QAOSFIND(2)=$P($G(^QA(741,QAOSD0,"REVR",QAOSD1,0)),"^",5)
S QAOSNEWF=0 I QAOSFIND(1),QAOSFIND(2)'=QAOSFIND(1) S QAOSNEWF=1
S QAOS=+$G(^QA(741.6,+QAOSFIND(2),0))
I QAOSFDSP("F")[("^"_QAOS_"^") S (QAOSQUIT,QAOSFDSP)=1
ACTION ;
I QAOSNEWF W !!?5,"Since the findings have been changed, you must review the actions.",!?5,"Delete any old actions that no longer apply, and add new actions that",!?5,"are now appropriate."
S:$D(^QA(741,QAOSD0,"REVR",QAOSD1,2,0))[0 ^(0)="^741.15PA^^"
K DR S DIE="^QA(741,"_QAOSD0_",""REVR"","
S DR="5"_$S(QAOSQUIT:"//^S X=1",1:""),(D0,DA(1))=QAOSD0,(D1,DA)=QAOSD1
D ^DIE G:$D(Y) EXIT
D CHKACT^QAOEDT0
K DR S DIE="^QA(741,"_QAOSD0_",""REVR"",",DR="10;1;9//NO"
S (D0,DA(1))=QAOSD0,(D1,DA)=QAOSD1 D ^DIE G:$D(Y) EXIT
ATTRIB ;
W !!?5,"Do you wish to enter peer attributions"
S %=2 D YN^DICN G:(%=-1)!(%=2) EXIT
I '% D G ATTRIB
. W !!?10,"Enter Y(es) to edit the individual, medical team, and"
. W !?10,"hospital location attribution data."
. W !?10,"Enter N(o) to skip the attribution edit."
. Q
;
S QAOSSERV=$P($G(^QA(741,QAOSD0,"REVR",QAOSD1,0)),"^",10)
F QAOFIELD=24:1:26 W ! D Q:QAOSQUIT
. S QAOSUBDD="741.0"_QAOFIELD
. S QAOSNODE="ATR"_$S(QAOFIELD=24:"I",QAOFIELD=25:"T",QAOFIELD=26:"L")
. S:'$D(^QA(741,QAOSD0,QAOSNODE,0)) ^(0)="^"_QAOSUBDD_"PA^^"
AGAIN . K DA,DIC,DIE,DR
. S DIC="^QA(741,"_QAOSD0_","""_QAOSNODE_""",",DIC(0)="AELMNQ"
. S DIC("S")="S QA=$P($G(^(0)),""^"",2) I QA=""""!(QA=QAOSSERV)"
. S DA(1)=QAOSD0,DLAYGO=QAOSUBDD
. D ^DIC S QAOSD1=+Y
. I Y'>0 S QAOSQUIT=$S($D(DUOUT):1,$D(DTOUT):1,1:0) Q
. S DIE=DIC,(D0,DA(1))=QAOSD0,(D1,DA)=QAOSD1
. S DR=".01" S:QAOSSERV DR=DR_";.02///`"_QAOSSERV
. D ^DIE
. G AGAIN
EXIT ;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOEDT0P 2430 printed Nov 22, 2024@17:31:07 Page 2
QAOEDT0P ;HISC/DAD-PEER REVIEW LEVEL EDIT ;2/3/93 15:57
+1 ;;3.0;Occurrence Screen;;09/14/1993
REVLEV SET (QAOSQUIT,QAOSNEWF)=0
SET QAOSREVR(0)=+^QA(741,QAOSD0,"REVR",QAOSD1,0)
+1 KILL DR
SET DIE="^QA(741,"_QAOSD0_",""REVR"","
SET DR=".01"
+2 SET (D0,DA(1))=QAOSD0
SET (D1,DA)=QAOSD1
DO ^DIE
if ('$DATA(DA))!($DATA(Y))
GOTO EXIT
+3 SET QAOSREVR(1)=+^QA(741,QAOSD0,"REVR",QAOSD1,0)
+4 IF QAOSREVR(0)'=QAOSREVR(1)
DO RESET^QAOEDT0
GOTO REVLEV
+5 KILL DR
SET DIE="^QA(741,"_QAOSD0_",""REVR"","
SET DR=".02T;.03"
+6 SET (D0,DA(1))=QAOSD0
SET (D1,DA)=QAOSD1
DO ^DIE
if $DATA(Y)
GOTO EXIT
FINDING ;
+1 SET QAOSFIND(1)=$PIECE($GET(^QA(741,QAOSD0,"REVR",QAOSD1,0)),"^",5)
+2 KILL DR
SET DIE="^QA(741,"_QAOSD0_",""REVR"","
SET DR="4"
+3 SET (D0,DA(1))=QAOSD0
SET (D1,DA)=QAOSD1
DO ^DIE
if $DATA(Y)
GOTO EXIT
+4 SET QAOSFIND(2)=$PIECE($GET(^QA(741,QAOSD0,"REVR",QAOSD1,0)),"^",5)
+5 SET QAOSNEWF=0
IF QAOSFIND(1)
IF QAOSFIND(2)'=QAOSFIND(1)
SET QAOSNEWF=1
+6 SET QAOS=+$GET(^QA(741.6,+QAOSFIND(2),0))
+7 IF QAOSFDSP("F")[("^"_QAOS_"^")
SET (QAOSQUIT,QAOSFDSP)=1
ACTION ;
+1 IF QAOSNEWF
WRITE !!?5,"Since the findings have been changed, you must review the actions.",!?5,"Delete any old actions that no longer apply, and add new actions that",!?5,"are now appropriate."
+2 if $DATA(^QA(741,QAOSD0,"REVR",QAOSD1,2,0))[0
SET ^(0)="^741.15PA^^"
+3 KILL DR
SET DIE="^QA(741,"_QAOSD0_",""REVR"","
+4 SET DR="5"_$SELECT(QAOSQUIT:"//^S X=1",1:"")
SET (D0,DA(1))=QAOSD0
SET (D1,DA)=QAOSD1
+5 DO ^DIE
if $DATA(Y)
GOTO EXIT
+6 DO CHKACT^QAOEDT0
+7 KILL DR
SET DIE="^QA(741,"_QAOSD0_",""REVR"","
SET DR="10;1;9//NO"
+8 SET (D0,DA(1))=QAOSD0
SET (D1,DA)=QAOSD1
DO ^DIE
if $DATA(Y)
GOTO EXIT
ATTRIB ;
+1 WRITE !!?5,"Do you wish to enter peer attributions"
+2 SET %=2
DO YN^DICN
if (%=-1)!(%=2)
GOTO EXIT
+3 IF '%
Begin DoDot:1
+4 WRITE !!?10,"Enter Y(es) to edit the individual, medical team, and"
+5 WRITE !?10,"hospital location attribution data."
+6 WRITE !?10,"Enter N(o) to skip the attribution edit."
+7 QUIT
End DoDot:1
GOTO ATTRIB
+8 ;
+9 SET QAOSSERV=$PIECE($GET(^QA(741,QAOSD0,"REVR",QAOSD1,0)),"^",10)
+10 FOR QAOFIELD=24:1:26
WRITE !
Begin DoDot:1
+11 SET QAOSUBDD="741.0"_QAOFIELD
+12 SET QAOSNODE="ATR"_$SELECT(QAOFIELD=24:"I",QAOFIELD=25:"T",QAOFIELD=26:"L")
+13 if '$DATA(^QA(741,QAOSD0,QAOSNODE,0))
SET ^(0)="^"_QAOSUBDD_"PA^^"
AGAIN KILL DA,DIC,DIE,DR
+1 SET DIC="^QA(741,"_QAOSD0_","""_QAOSNODE_""","
SET DIC(0)="AELMNQ"
+2 SET DIC("S")="S QA=$P($G(^(0)),""^"",2) I QA=""""!(QA=QAOSSERV)"
+3 SET DA(1)=QAOSD0
SET DLAYGO=QAOSUBDD
+4 DO ^DIC
SET QAOSD1=+Y
+5 IF Y'>0
SET QAOSQUIT=$SELECT($DATA(DUOUT):1,$DATA(DTOUT):1,1:0)
QUIT
+6 SET DIE=DIC
SET (D0,DA(1))=QAOSD0
SET (D1,DA)=QAOSD1
+7 SET DR=".01"
if QAOSSERV
SET DR=DR_";.02///`"_QAOSSERV
+8 DO ^DIE
+9 GOTO AGAIN
End DoDot:1
if QAOSQUIT
QUIT
EXIT ;
+1 QUIT
