QAOEDT0 ;HISC/DAD-CLINICAL, PEER, & MANAGER REVIEW ;6/24/93 15:34
;;3.0;Occurrence Screen;;09/14/1993
ASKDFN ;
D HOME^%ZIS
S QALIMIT="I $P(^(0),""^"",11)'>0",QAOSPROG="EN1^QAOEDT0" D EN2^QAOEDT
K %,D,D0,D1,DA,DD,DIC,DIE,DINUM,DO,DR,DZ,QAOS,QAOSD0,QAOSD1,QAOSD2
K QAOSDATA,QAOSDATE,QAOSDFN,QAOSFIND,QAOSFOND,QAOSLEVL,QAOSLVNO
K QAOSMDUE,QAOSNEWF,QAOSPDUE,QAOSQUIT,QAOSSCRN,QAOSWARD,QAOSWHAT
K QAOSX,QAOSZERO,SAVEX,SAVEY,UNDL,X,Y,QA,QAOSFDSP,QAOSFIND,QAUDIT
K QAOSLOC,QAOSMGMT,QAOSREVR,QALIMIT,QAOSONE,QAOSPROG,QAOFIELD,QAOSNODE
K QAOSSERV,QAOSUBDD
Q
EN1 ;
; *** FINAL DISPOSITION ACTIONS AND FINDINGS
S (QAOSQUIT,QAOSFDSP)=0,QAOSFDSP("A")="^1^1.1^",QAOSFDSP("F")="^1^3^11^"
S QAOSWHAT="REVIEWED" D ENDISP^QAOUTL0
K DR S DIE="^QA(741,",DR="19;5;6;7;8;9",DA=QAOSD0
D ^DIE I $D(Y) S QAOSQUIT=1 D AUDIT("e","CLINICAL/PEER/MANAGEMENT REVIEW") G DONE
W !!?5,"Select CLINICAL, PEER, or MANAGEMENT review level."
W !?5,"Only one CLINICAL review level may be entered."
D ASKLEVL
I QAOSQUIT D AUDIT("e","CLINICAL/PEER/MANAGEMENT REVIEW") G DONE
ASKDISP ;
S QAOSMGMT=+$O(^QA(741.2,"C",3,0))
S QAOSFDSP=$S($O(^QA(741,QAOSD0,"REVR","B",QAOSMGMT,0)):1,1:QAOSFDSP)
G:QAOSFDSP'>0 DONE
W !!?5,"Do you wish to enter a FINAL DISPOSITION"
S %=2 D YN^DICN G:(%=-1)!(%=2) DONE
I '% D G ASKDISP
. W !!?10,"Enter Y(es) to edit the FINAL DISPOSITION DATE and FINAL"
. W !?10,"DISPOSITION REACHED BY data."
. W !?10,"Enter N(o) to skip the FINAL DISPOSITION and select the next patient."
. Q
S QAOSWHAT="CLOSED OUT" D ENDISP^QAOUTL0
K DR S DIE="^QA(741,",DR="14//TODAY;16;11//CLOSED",DA=QAOSD0
D ^DIE I $D(Y) S QAOSQUIT=1
D AUDIT("c","CLOSE A RECORD")
DONE ;
Q
ASKLEVL ;
R !!,"Select REVIEW LEVEL: ",X:DTIME S:'$T X="^"
I "^"[$E(X) S QAOSQUIT=($E(X)="^") Q
I $E(X)="?" D
. N X K DIC S DIC="^QA(741,"_QAOSD0_",""REVR"",",DIC(0)="MQZ"
. S D="B",DZ="??",(D0,DA,DA(1))=QAOSD0
. W !!,"Already existing reviews for this occurrence:"
. S QAOSDATA=$O(^QA(741,QAOSD0,"REVR",0)) D:QAOSDATA DQ^DICQ
. W:QAOSDATA'>0 !?5,"*** NONE ***",!!,"Other review level choices:"
. Q
K DIC S DIC="^QA(741.2,",DIC(0)="EMNQZ"
S DIC("S")="I $P(^(0),""^"",2)'>3" D ^DIC K DIC G:Y'>0 ASKLEVL
S QAOSLEVL=+Y,QAOSLEVL(0)=Y(0,0),QAOSLVNO=$P(Y(0),"^",2)
SEARCH ;
K QAOSFOND
S QAOSFOND="",QAOSD1=$O(^QA(741,QAOSD0,"REVR","B",QAOSLEVL,0))
I QAOSLVNO=1,QAOSD1,$D(^QA(741,QAOSD0,"REVR",QAOSD1,0))#2 G EDIT
W:QAOSD1 !!,"Choose from:"
F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"REVR","B",QAOSLEVL,QAOSD1)) Q:QAOSD1'>0 S QAOS=$G(^QA(741,QAOSD0,"REVR",QAOSD1,0)) D:QAOS]""
. S QAOSFOND=QAOSFOND_QAOSD1_","
. S QAOSFOND(QAOSD1)=QAOSLEVL(0)_" "_$P($G(^VA(200,+$P(QAOS,"^",2),0)),"^")_" "_$P($G(^DIC(49,+$P(QAOS,"^",10),0)),"^")
. W !?5,QAOSD1,?15,QAOSFOND(QAOSD1)
. Q
S QAOSFOND=$E(QAOSFOND,1,$L(QAOSFOND)-1) G:QAOSFOND'>0 ASKADD
W !!,"Choose (",QAOSFOND,"): "
R QAOSD1:DTIME S:'$T QAOSD1="^" G:$E(QAOSD1)="^" ASKLEVL
I QAOSD1]"" D G:QA SEARCH
. S QA=($D(^QA(741,QAOSD0,"REVR",+QAOSD1,0))[0)
. S QA=((","_QAOSFOND_",")'[(","_QAOSD1_","))+QA
. I QA D
.. W:$E(QAOSD1)'="?" " ??",*7
.. W !!?5,"Enter one of the numbers listed below, or press RETURN"
.. W !?5,"to add a new ",QAOSLEVL(0)," review level. "
.. W "Up-arrow (^) to exit."
.. Q
. Q
W " ",$G(QAOSFOND(+QAOSD1))
G:QAOSD1 EDIT
ASKADD ;
G:$O(^QA(741,QAOSD0,"REVR","B",QAOSLEVL,0))'>0 ADD
W *7,!!?5,"Are you adding ",QAOSLEVL(0)," as a new review level"
S %=2 D YN^DICN G:(%=-1)!(%=2) ASKLEVL
I '% D G ASKADD
. W !!?5,"Enter Y(es) to create a new review level."
. W !?5,"Enter N(o) to skip adding another review level."
. Q
ADD S:$D(^QA(741,QAOSD0,"REVR",0))[0 ^(0)="^741.01IPA^^"
K DD,DIC,DINUM,DO S DIC="^QA(741,"_QAOSD0_",""REVR"",",DIC(0)="LM"
S X=QAOSLEVL,(D0,DA,DA(1))=QAOSD0
D FILE^DICN S QAOSD1=+Y
EDIT ;
W ! D ^QAOEDT0C:QAOSLVNO=1,^QAOEDT0P:QAOSLVNO=2,^QAOEDT0M:QAOSLVNO=3
D AUDIT("e","CLINICAL/PEER/MANAGEMENT REVIEW") G ASKLEVL
CHKACT ;
F QA=0:0 S QA=$O(^QA(741,QAOSD0,"REVR",QAOSD1,2,"B",QA)) Q:QA'>0 S QAOS=$P($G(^QA(741.7,QA,0)),"^") I QAOSFDSP("A")[("^"_QAOS_"^") S (QAOSQUIT,QAOSFDSP)=1 Q
Q
RESET ;
W *7
W !!?5,"You may not change the review level, but you may delete it (@)"
W !?5,"if you wish. Resetting the review level to its original value."
W !,*7
K DR S DIE="^QA(741,"_QAOSD0_",""REVR"","
S DR=".01////"_QAOSREVR(0),(D0,DA(1))=QAOSD0,(D1,DA)=QAOSD1
D ^DIE
Q
AUDIT(A,C) ; AUDIT: A = ACTION, C = COMMENT
N QAUDIT S QAUDIT("ACTION")=A,QAUDIT("COMMENT")=C
S QAUDIT("FILE")="741^27",QAUDIT("DA")=QAOSD0
D ^QAQAUDIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOEDT0 4634 printed Apr 09, 2024@21:22:49 Page 2
QAOEDT0 ;HISC/DAD-CLINICAL, PEER, & MANAGER REVIEW ;6/24/93 15:34
+1 ;;3.0;Occurrence Screen;;09/14/1993
ASKDFN ;
+1 DO HOME^%ZIS
+2 SET QALIMIT="I $P(^(0),""^"",11)'>0"
SET QAOSPROG="EN1^QAOEDT0"
DO EN2^QAOEDT
+3 KILL %,D,D0,D1,DA,DD,DIC,DIE,DINUM,DO,DR,DZ,QAOS,QAOSD0,QAOSD1,QAOSD2
+4 KILL QAOSDATA,QAOSDATE,QAOSDFN,QAOSFIND,QAOSFOND,QAOSLEVL,QAOSLVNO
+5 KILL QAOSMDUE,QAOSNEWF,QAOSPDUE,QAOSQUIT,QAOSSCRN,QAOSWARD,QAOSWHAT
+6 KILL QAOSX,QAOSZERO,SAVEX,SAVEY,UNDL,X,Y,QA,QAOSFDSP,QAOSFIND,QAUDIT
+7 KILL QAOSLOC,QAOSMGMT,QAOSREVR,QALIMIT,QAOSONE,QAOSPROG,QAOFIELD,QAOSNODE
+8 KILL QAOSSERV,QAOSUBDD
+9 QUIT
EN1 ;
+1 ; *** FINAL DISPOSITION ACTIONS AND FINDINGS
+2 SET (QAOSQUIT,QAOSFDSP)=0
SET QAOSFDSP("A")="^1^1.1^"
SET QAOSFDSP("F")="^1^3^11^"
+3 SET QAOSWHAT="REVIEWED"
DO ENDISP^QAOUTL0
+4 KILL DR
SET DIE="^QA(741,"
SET DR="19;5;6;7;8;9"
SET DA=QAOSD0
+5 DO ^DIE
IF $DATA(Y)
SET QAOSQUIT=1
DO AUDIT("e","CLINICAL/PEER/MANAGEMENT REVIEW")
GOTO DONE
+6 WRITE !!?5,"Select CLINICAL, PEER, or MANAGEMENT review level."
+7 WRITE !?5,"Only one CLINICAL review level may be entered."
+8 DO ASKLEVL
+9 IF QAOSQUIT
DO AUDIT("e","CLINICAL/PEER/MANAGEMENT REVIEW")
GOTO DONE
ASKDISP ;
+1 SET QAOSMGMT=+$ORDER(^QA(741.2,"C",3,0))
+2 SET QAOSFDSP=$SELECT($ORDER(^QA(741,QAOSD0,"REVR","B",QAOSMGMT,0)):1,1:QAOSFDSP)
+3 if QAOSFDSP'>0
GOTO DONE
+4 WRITE !!?5,"Do you wish to enter a FINAL DISPOSITION"
+5 SET %=2
DO YN^DICN
if (%=-1)!(%=2)
GOTO DONE
+6 IF '%
Begin DoDot:1
+7 WRITE !!?10,"Enter Y(es) to edit the FINAL DISPOSITION DATE and FINAL"
+8 WRITE !?10,"DISPOSITION REACHED BY data."
+9 WRITE !?10,"Enter N(o) to skip the FINAL DISPOSITION and select the next patient."
+10 QUIT
End DoDot:1
GOTO ASKDISP
+11 SET QAOSWHAT="CLOSED OUT"
DO ENDISP^QAOUTL0
+12 KILL DR
SET DIE="^QA(741,"
SET DR="14//TODAY;16;11//CLOSED"
SET DA=QAOSD0
+13 DO ^DIE
IF $DATA(Y)
SET QAOSQUIT=1
+14 DO AUDIT("c","CLOSE A RECORD")
DONE ;
+1 QUIT
ASKLEVL ;
+1 READ !!,"Select REVIEW LEVEL: ",X:DTIME
if '$TEST
SET X="^"
+2 IF "^"[$EXTRACT(X)
SET QAOSQUIT=($EXTRACT(X)="^")
QUIT
+3 IF $EXTRACT(X)="?"
Begin DoDot:1
+4 NEW X
KILL DIC
SET DIC="^QA(741,"_QAOSD0_",""REVR"","
SET DIC(0)="MQZ"
+5 SET D="B"
SET DZ="??"
SET (D0,DA,DA(1))=QAOSD0
+6 WRITE !!,"Already existing reviews for this occurrence:"
+7 SET QAOSDATA=$ORDER(^QA(741,QAOSD0,"REVR",0))
if QAOSDATA
DO DQ^DICQ
+8 if QAOSDATA'>0
WRITE !?5,"*** NONE ***",!!,"Other review level choices:"
+9 QUIT
End DoDot:1
+10 KILL DIC
SET DIC="^QA(741.2,"
SET DIC(0)="EMNQZ"
+11 SET DIC("S")="I $P(^(0),""^"",2)'>3"
DO ^DIC
KILL DIC
if Y'>0
GOTO ASKLEVL
+12 SET QAOSLEVL=+Y
SET QAOSLEVL(0)=Y(0,0)
SET QAOSLVNO=$PIECE(Y(0),"^",2)
SEARCH ;
+1 KILL QAOSFOND
+2 SET QAOSFOND=""
SET QAOSD1=$ORDER(^QA(741,QAOSD0,"REVR","B",QAOSLEVL,0))
+3 IF QAOSLVNO=1
IF QAOSD1
IF $DATA(^QA(741,QAOSD0,"REVR",QAOSD1,0))#2
GOTO EDIT
+4 if QAOSD1
WRITE !!,"Choose from:"
+5 FOR QAOSD1=0:0
SET QAOSD1=$ORDER(^QA(741,QAOSD0,"REVR","B",QAOSLEVL,QAOSD1))
if QAOSD1'>0
QUIT
SET QAOS=$GET(^QA(741,QAOSD0,"REVR",QAOSD1,0))
if QAOS]""
Begin DoDot:1
+6 SET QAOSFOND=QAOSFOND_QAOSD1_","
+7 SET QAOSFOND(QAOSD1)=QAOSLEVL(0)_" "_$PIECE($GET(^VA(200,+$PIECE(QAOS,"^",2),0)),"^")_" "_$PIECE($GET(^DIC(49,+$PIECE(QAOS,"^",10),0)),"^")
+8 WRITE !?5,QAOSD1,?15,QAOSFOND(QAOSD1)
+9 QUIT
End DoDot:1
+10 SET QAOSFOND=$EXTRACT(QAOSFOND,1,$LENGTH(QAOSFOND)-1)
if QAOSFOND'>0
GOTO ASKADD
+11 WRITE !!,"Choose (",QAOSFOND,"): "
+12 READ QAOSD1:DTIME
if '$TEST
SET QAOSD1="^"
if $EXTRACT(QAOSD1)="^"
GOTO ASKLEVL
+13 IF QAOSD1]""
Begin DoDot:1
+14 SET QA=($DATA(^QA(741,QAOSD0,"REVR",+QAOSD1,0))[0)
+15 SET QA=((","_QAOSFOND_",")'[(","_QAOSD1_","))+QA
+16 IF QA
Begin DoDot:2
+17 if $EXTRACT(QAOSD1)'="?"
WRITE " ??",*7
+18 WRITE !!?5,"Enter one of the numbers listed below, or press RETURN"
+19 WRITE !?5,"to add a new ",QAOSLEVL(0)," review level. "
+20 WRITE "Up-arrow (^) to exit."
+21 QUIT
End DoDot:2
+22 QUIT
End DoDot:1
if QA
GOTO SEARCH
+23 WRITE " ",$GET(QAOSFOND(+QAOSD1))
+24 if QAOSD1
GOTO EDIT
ASKADD ;
+1 if $ORDER(^QA(741,QAOSD0,"REVR","B",QAOSLEVL,0))'>0
GOTO ADD
+2 WRITE *7,!!?5,"Are you adding ",QAOSLEVL(0)," as a new review level"
+3 SET %=2
DO YN^DICN
if (%=-1)!(%=2)
GOTO ASKLEVL
+4 IF '%
Begin DoDot:1
+5 WRITE !!?5,"Enter Y(es) to create a new review level."
+6 WRITE !?5,"Enter N(o) to skip adding another review level."
+7 QUIT
End DoDot:1
GOTO ASKADD
ADD if $DATA(^QA(741,QAOSD0,"REVR",0))[0
SET ^(0)="^741.01IPA^^"
+1 KILL DD,DIC,DINUM,DO
SET DIC="^QA(741,"_QAOSD0_",""REVR"","
SET DIC(0)="LM"
+2 SET X=QAOSLEVL
SET (D0,DA,DA(1))=QAOSD0
+3 DO FILE^DICN
SET QAOSD1=+Y
EDIT ;
+1 WRITE !
if QAOSLVNO=1
DO ^QAOEDT0C
if QAOSLVNO=2
DO ^QAOEDT0P
if QAOSLVNO=3
DO ^QAOEDT0M
+2 DO AUDIT("e","CLINICAL/PEER/MANAGEMENT REVIEW")
GOTO ASKLEVL
CHKACT ;
+1 FOR QA=0:0
SET QA=$ORDER(^QA(741,QAOSD0,"REVR",QAOSD1,2,"B",QA))
if QA'>0
QUIT
SET QAOS=$PIECE($GET(^QA(741.7,QA,0)),"^")
IF QAOSFDSP("A")[("^"_QAOS_"^")
SET (QAOSQUIT,QAOSFDSP)=1
QUIT
+2 QUIT
RESET ;
+1 WRITE *7
+2 WRITE !!?5,"You may not change the review level, but you may delete it (@)"
+3 WRITE !?5,"if you wish. Resetting the review level to its original value."
+4 WRITE !,*7
+5 KILL DR
SET DIE="^QA(741,"_QAOSD0_",""REVR"","
+6 SET DR=".01////"_QAOSREVR(0)
SET (D0,DA(1))=QAOSD0
SET (D1,DA)=QAOSD1
+7 DO ^DIE
+8 QUIT
AUDIT(A,C) ; AUDIT: A = ACTION, C = COMMENT
+1 NEW QAUDIT
SET QAUDIT("ACTION")=A
SET QAUDIT("COMMENT")=C
+2 SET QAUDIT("FILE")="741^27"
SET QAUDIT("DA")=QAOSD0
+3 DO ^QAQAUDIT
+4 QUIT
