QAOEDT0C ;HISC/DAD-CLINICAL REVIEW LEVEL EDIT ;2/3/93 16:00
;;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"
S (D0,DA(1))=QAOSD0,(D1,DA)=QAOSD1 D ^DIE G:$D(Y) EXIT
I $O(^QA(741.5,"C",+$G(^QA(741,QAOSD0,"SCRN")),0))'>0 G FINDING
S:$D(^QA(741,QAOSD0,"REVR",QAOSD1,1,0))[0 ^(0)="^741.12PA^^"
K DR S DIE="^QA(741,"_QAOSD0_",""REVR"",",DR="2"
S (D0,DA(1))=QAOSD0,(D1,DA)=QAOSD1 D ^DIE G:$D(Y) EXIT
I $O(^QA(741,QAOSD0,"REVR",QAOSD1,1,"B",0)) S QAOSQUIT=1 D EXCEPT G ACTION
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 G ACTION
K DR S DIE="^QA(741,"_QAOSD0_",""REVR"",",DR="3"
S (D0,DA(1))=QAOSD0,(D1,DA)=QAOSD1 D ^DIE G:$D(Y) EXIT
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"
S (D0,DA(1))=QAOSD0,(D1,DA)=QAOSD1 D ^DIE G:$D(Y) EXIT
EXIT ;
Q
EXCEPT ;
S QAOS=+$O(^QA(741.6,"B",3,0)) Q:QAOS'>0
S QAOS=$P($G(^QA(741.6,+QAOS,0)),"^",2) Q:QAOS=""
W !!,"A finding of ",QAOS," is automatically being entered.",!
K DR S DIE="^QA(741,"_QAOSD0_",""REVR"",",DR="4///^S X=3"
S (D0,DA(1))=QAOSD0,(D1,DA)=QAOSD1 D ^DIE S QAOSFDSP=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOEDT0C 2188 printed Dec 13, 2024@02:21:06 Page 2
QAOEDT0C ;HISC/DAD-CLINICAL REVIEW LEVEL EDIT ;2/3/93 16:00
+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"
+6 SET (D0,DA(1))=QAOSD0
SET (D1,DA)=QAOSD1
DO ^DIE
if $DATA(Y)
GOTO EXIT
+7 IF $ORDER(^QA(741.5,"C",+$GET(^QA(741,QAOSD0,"SCRN")),0))'>0
GOTO FINDING
+8 if $DATA(^QA(741,QAOSD0,"REVR",QAOSD1,1,0))[0
SET ^(0)="^741.12PA^^"
+9 KILL DR
SET DIE="^QA(741,"_QAOSD0_",""REVR"","
SET DR="2"
+10 SET (D0,DA(1))=QAOSD0
SET (D1,DA)=QAOSD1
DO ^DIE
if $DATA(Y)
GOTO EXIT
+11 IF $ORDER(^QA(741,QAOSD0,"REVR",QAOSD1,1,"B",0))
SET QAOSQUIT=1
DO EXCEPT
GOTO ACTION
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
GOTO ACTION
+8 KILL DR
SET DIE="^QA(741,"_QAOSD0_",""REVR"","
SET DR="3"
+9 SET (D0,DA(1))=QAOSD0
SET (D1,DA)=QAOSD1
DO ^DIE
if $DATA(Y)
GOTO EXIT
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"
+8 SET (D0,DA(1))=QAOSD0
SET (D1,DA)=QAOSD1
DO ^DIE
if $DATA(Y)
GOTO EXIT
EXIT ;
+1 QUIT
EXCEPT ;
+1 SET QAOS=+$ORDER(^QA(741.6,"B",3,0))
if QAOS'>0
QUIT
+2 SET QAOS=$PIECE($GET(^QA(741.6,+QAOS,0)),"^",2)
if QAOS=""
QUIT
+3 WRITE !!,"A finding of ",QAOS," is automatically being entered.",!
+4 KILL DR
SET DIE="^QA(741,"_QAOSD0_",""REVR"","
SET DR="4///^S X=3"
+5 SET (D0,DA(1))=QAOSD0
SET (D1,DA)=QAOSD1
DO ^DIE
SET QAOSFDSP=1
+6 QUIT