QAOEDT1 ;HISC/DAD-QUICK EXCEPTION EDIT ;7/26/93 13:09
;;3.0;Occurrence Screen;;09/14/1993
D HOME^%ZIS
S QAOSCLIN=$O(^QA(741.2,"C",1,0)),QAOSFIND=$O(^QA(741.6,"B",3,0))
S QAOSACTN=$O(^QA(741.7,"B",1,0)) D NOW^%DTC S QAOSDT=X
ASKCLIN ;
K DIC S DIC="^VA(200,",DIC(0)="AEQ"
S DIC("A")="Select CLINICAL REVIEWER: "
S DIC("S")="I $D(^XUSEC(""QAOSCLIN"",+Y))",D="AK.QAOSCLIN"
W ! D IX^DIC G:Y'>0 EXIT S QAOSREVR=+Y
S QALIMIT="I $P(^(0),""^"",11)'>0",QAOSPROG="DFN^QAOEDT1" D EN2^QAOEDT
G ASKCLIN
DFN ;
S QAOSQUIT=0,QAOSWHAT="REVIEWED" D ENDISP^QAOUTL0
I $O(^QA(741,QAOSD0,"REVR",0)) D Q
. W *7,!!?15,"*** REVIEWS ALREADY EXIST FOR THIS OCCURRENCE ***"
. W !?2,"*** Use the 'Clinical, Peer, Manager Review' option to edit exceptions ***",!,*7
. K DIR S DIR(0)="E" D ^DIR S QAOSQUIT=$S(Y'>0:1,1:0)
. Q
D EXCEPT Q:QAOSQUIT
ASKOK ;
G:$O(^TMP($J,"QAOS EXCEPTION",0)) DOIT
W !!?5,"Mark this record as an exception (Y/N) "
S %=2 D YN^DICN I '% W !!?10,"Please answer Y(es) or N(o)" G ASKOK
S:%=-1 QAOSQUIT=1 Q:%'=1
DOIT ;
W !!,"Entering Clinical Review Findings as Exception to Criteria..."
S ^QA(741,QAOSD0,"REVR",0)="^741.01IPA^1^1"
S ^QA(741,QAOSD0,"REVR",1,0)=QAOSCLIN_"^"_QAOSREVR_"^"_QAOSDT_"^^"_QAOSFIND
S ^QA(741,QAOSD0,"REVR",1,2,0)="^741.15PA^1^1"
S ^QA(741,QAOSD0,"REVR",1,2,1,0)=QAOSACTN
I QAOSQUIT'>0 D
. S QAOS=0
. F QAOS1=0:0 S QAOS1=$O(^TMP($J,"QAOS EXCEPTION",QAOS1)) Q:QAOS1'>0 D
.. S QAOS=QAOS+1,^QA(741,QAOSD0,"REVR",1,1,QAOS,0)=QAOS1
.. Q
. S ^QA(741,QAOSD0,"REVR",1,1,0)="^741.12PA^"_QAOS_"^"_QAOS
. Q
S DIK="^QA(741,",DA=QAOSD0 D IX1^DIK K DIK
S QAUDIT("FILE")="741^27",QAUDIT("DA")=QAOSD0,QAUDIT("ACTION")="e"
S QAUDIT("COMMENT")="QUICK EXCEPTION EDIT" D ^QAQAUDIT
W "Finished"
W !,"Entering Final Disposition..."
K DR S DIE="^QA(741,",DR="11///1;14///TODAY;16///`"_QAOSCLIN
S (D0,DA)=QAOSD0 D ^DIE
S QAUDIT("FILE")="741^27",QAUDIT("DA")=QAOSD0,QAUDIT("ACTION")="c"
S QAUDIT("COMMENT")="CLOSE A RECORD" D ^QAQAUDIT
W "Finished"
Q
EXIT ;
K D,D0,DA,DIC,DIE,DIK,DIR,DR,QA,QAOS,QAOS1,QAOSACTN,QAOSCLIN,QAOSD0,QAQA
K QAOSDSEL,QAOSDT,QAOSFIND,QAOSLINE,QAOSNUM,QAOSQUIT,QAOSREVR,QAOSSCRN
K QAOSWHAT,QAUDIT,X,Y,QALIMIT,QAOSONE,QAOSPROG,^TMP($J,"QAOS EXCEPTION")
Q
EXCEPT ; *** SELECT A GROUP OF EXCEPTIONS
; *** RETURNS ^TMP($J,"QAOS EXCEPTION",EXCEPTION IEN)=""
; *** RETURNS QAOSQUIT = $S('^' OUT:1,TIME OUT:1,1:0)
S QAOSQUIT=0,QAOSNUM=1,QAOSSCRN=+$G(^QA(741,QAOSD0,"SCRN"))
K ^TMP($J,"QAOS EXCEPTION")
ASKEXC ;
W !!,$S(QAOSNUM>1:"Another one",1:"Select EXCEPTION")_": "
R X:DTIME S:('$T)!($E(X)="^") QAOSQUIT=1 Q:X=""!QAOSQUIT
I X?1"?".E D
. W !!?5,"Select an exception name or number, to deselect an item"
. W !?5,"type a minus sign (-) in front of it, e.g. -EXCEPTION.",!
. D:$O(^TMP($J,"QAOS EXCEPTION",0)) SHOW
. Q
K DIC S DIC="^QA(741.5,",DIC(0)="EMNQ"
S DIC("S")="S QA=^(0) I $P(QA,""^"",2)=QAOSSCRN,$P(QA,""^"",4)'>0"
S QAOSDSEL=$S(X?1"-".E:1,1:0) S:QAOSDSEL X=$E(X,2,$L(X))
D ^DIC K DIC G:+Y'>0 ASKEXC
I 'QAOSDSEL,'$D(^TMP($J,"QAOS EXCEPTION",+Y)) D
. S ^TMP($J,"QAOS EXCEPTION",+Y)="",QAOSNUM=QAOSNUM+1
. Q
I QAOSDSEL,$D(^TMP($J,"QAOS EXCEPTION",+Y)) D
. K ^TMP($J,"QAOS EXCEPTION",+Y) S QAOSNUM=QAOSNUM-$S(QAOSNUM>0:1,1:0)
. Q
G ASKEXC
SHOW ;
N X S QAOSLINE=$Y,QAOS1="" W !,"You have already selected:"
F QAOS1=0:0 S QAOS1=$O(^TMP($J,"QAOS EXCEPTION",QAOS1)) Q:QAOS1'>0!QAOSQUIT D
. S QAOS=$G(^QA(741.5,QAOS1,0))
. W !?3,$P(QAOS,"^",3)," ",$P(QAOS,"^") D:$Y>(IOSL+QAOSLINE-3)
.. K DIR S DIR(0)="E" D ^DIR S QAOSQUIT=$S(Y'>0:1,1:0),QAOSLINE=$Y
.. Q
. Q
W ! S QAOSQUIT=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOEDT1 3659 printed Dec 13, 2024@02:21:08 Page 2
QAOEDT1 ;HISC/DAD-QUICK EXCEPTION EDIT ;7/26/93 13:09
+1 ;;3.0;Occurrence Screen;;09/14/1993
+2 DO HOME^%ZIS
+3 SET QAOSCLIN=$ORDER(^QA(741.2,"C",1,0))
SET QAOSFIND=$ORDER(^QA(741.6,"B",3,0))
+4 SET QAOSACTN=$ORDER(^QA(741.7,"B",1,0))
DO NOW^%DTC
SET QAOSDT=X
ASKCLIN ;
+1 KILL DIC
SET DIC="^VA(200,"
SET DIC(0)="AEQ"
+2 SET DIC("A")="Select CLINICAL REVIEWER: "
+3 SET DIC("S")="I $D(^XUSEC(""QAOSCLIN"",+Y))"
SET D="AK.QAOSCLIN"
+4 WRITE !
DO IX^DIC
if Y'>0
GOTO EXIT
SET QAOSREVR=+Y
+5 SET QALIMIT="I $P(^(0),""^"",11)'>0"
SET QAOSPROG="DFN^QAOEDT1"
DO EN2^QAOEDT
+6 GOTO ASKCLIN
DFN ;
+1 SET QAOSQUIT=0
SET QAOSWHAT="REVIEWED"
DO ENDISP^QAOUTL0
+2 IF $ORDER(^QA(741,QAOSD0,"REVR",0))
Begin DoDot:1
+3 WRITE *7,!!?15,"*** REVIEWS ALREADY EXIST FOR THIS OCCURRENCE ***"
+4 WRITE !?2,"*** Use the 'Clinical, Peer, Manager Review' option to edit exceptions ***",!,*7
+5 KILL DIR
SET DIR(0)="E"
DO ^DIR
SET QAOSQUIT=$SELECT(Y'>0:1,1:0)
+6 QUIT
End DoDot:1
QUIT
+7 DO EXCEPT
if QAOSQUIT
QUIT
ASKOK ;
+1 if $ORDER(^TMP($JOB,"QAOS EXCEPTION",0))
GOTO DOIT
+2 WRITE !!?5,"Mark this record as an exception (Y/N) "
+3 SET %=2
DO YN^DICN
IF '%
WRITE !!?10,"Please answer Y(es) or N(o)"
GOTO ASKOK
+4 if %=-1
SET QAOSQUIT=1
if %'=1
QUIT
DOIT ;
+1 WRITE !!,"Entering Clinical Review Findings as Exception to Criteria..."
+2 SET ^QA(741,QAOSD0,"REVR",0)="^741.01IPA^1^1"
+3 SET ^QA(741,QAOSD0,"REVR",1,0)=QAOSCLIN_"^"_QAOSREVR_"^"_QAOSDT_"^^"_QAOSFIND
+4 SET ^QA(741,QAOSD0,"REVR",1,2,0)="^741.15PA^1^1"
+5 SET ^QA(741,QAOSD0,"REVR",1,2,1,0)=QAOSACTN
+6 IF QAOSQUIT'>0
Begin DoDot:1
+7 SET QAOS=0
+8 FOR QAOS1=0:0
SET QAOS1=$ORDER(^TMP($JOB,"QAOS EXCEPTION",QAOS1))
if QAOS1'>0
QUIT
Begin DoDot:2
+9 SET QAOS=QAOS+1
SET ^QA(741,QAOSD0,"REVR",1,1,QAOS,0)=QAOS1
+10 QUIT
End DoDot:2
+11 SET ^QA(741,QAOSD0,"REVR",1,1,0)="^741.12PA^"_QAOS_"^"_QAOS
+12 QUIT
End DoDot:1
+13 SET DIK="^QA(741,"
SET DA=QAOSD0
DO IX1^DIK
KILL DIK
+14 SET QAUDIT("FILE")="741^27"
SET QAUDIT("DA")=QAOSD0
SET QAUDIT("ACTION")="e"
+15 SET QAUDIT("COMMENT")="QUICK EXCEPTION EDIT"
DO ^QAQAUDIT
+16 WRITE "Finished"
+17 WRITE !,"Entering Final Disposition..."
+18 KILL DR
SET DIE="^QA(741,"
SET DR="11///1;14///TODAY;16///`"_QAOSCLIN
+19 SET (D0,DA)=QAOSD0
DO ^DIE
+20 SET QAUDIT("FILE")="741^27"
SET QAUDIT("DA")=QAOSD0
SET QAUDIT("ACTION")="c"
+21 SET QAUDIT("COMMENT")="CLOSE A RECORD"
DO ^QAQAUDIT
+22 WRITE "Finished"
+23 QUIT
EXIT ;
+1 KILL D,D0,DA,DIC,DIE,DIK,DIR,DR,QA,QAOS,QAOS1,QAOSACTN,QAOSCLIN,QAOSD0,QAQA
+2 KILL QAOSDSEL,QAOSDT,QAOSFIND,QAOSLINE,QAOSNUM,QAOSQUIT,QAOSREVR,QAOSSCRN
+3 KILL QAOSWHAT,QAUDIT,X,Y,QALIMIT,QAOSONE,QAOSPROG,^TMP($JOB,"QAOS EXCEPTION")
+4 QUIT
EXCEPT ; *** SELECT A GROUP OF EXCEPTIONS
+1 ; *** RETURNS ^TMP($J,"QAOS EXCEPTION",EXCEPTION IEN)=""
+2 ; *** RETURNS QAOSQUIT = $S('^' OUT:1,TIME OUT:1,1:0)
+3 SET QAOSQUIT=0
SET QAOSNUM=1
SET QAOSSCRN=+$GET(^QA(741,QAOSD0,"SCRN"))
+4 KILL ^TMP($JOB,"QAOS EXCEPTION")
ASKEXC ;
+1 WRITE !!,$SELECT(QAOSNUM>1:"Another one",1:"Select EXCEPTION")_": "
+2 READ X:DTIME
if ('$TEST)!($EXTRACT(X)="^")
SET QAOSQUIT=1
if X=""!QAOSQUIT
QUIT
+3 IF X?1"?".E
Begin DoDot:1
+4 WRITE !!?5,"Select an exception name or number, to deselect an item"
+5 WRITE !?5,"type a minus sign (-) in front of it, e.g. -EXCEPTION.",!
+6 if $ORDER(^TMP($JOB,"QAOS EXCEPTION",0))
DO SHOW
+7 QUIT
End DoDot:1
+8 KILL DIC
SET DIC="^QA(741.5,"
SET DIC(0)="EMNQ"
+9 SET DIC("S")="S QA=^(0) I $P(QA,""^"",2)=QAOSSCRN,$P(QA,""^"",4)'>0"
+10 SET QAOSDSEL=$SELECT(X?1"-".E:1,1:0)
if QAOSDSEL
SET X=$EXTRACT(X,2,$LENGTH(X))
+11 DO ^DIC
KILL DIC
if +Y'>0
GOTO ASKEXC
+12 IF 'QAOSDSEL
IF '$DATA(^TMP($JOB,"QAOS EXCEPTION",+Y))
Begin DoDot:1
+13 SET ^TMP($JOB,"QAOS EXCEPTION",+Y)=""
SET QAOSNUM=QAOSNUM+1
+14 QUIT
End DoDot:1
+15 IF QAOSDSEL
IF $DATA(^TMP($JOB,"QAOS EXCEPTION",+Y))
Begin DoDot:1
+16 KILL ^TMP($JOB,"QAOS EXCEPTION",+Y)
SET QAOSNUM=QAOSNUM-$SELECT(QAOSNUM>0:1,1:0)
+17 QUIT
End DoDot:1
+18 GOTO ASKEXC
SHOW ;
+1 NEW X
SET QAOSLINE=$Y
SET QAOS1=""
WRITE !,"You have already selected:"
+2 FOR QAOS1=0:0
SET QAOS1=$ORDER(^TMP($JOB,"QAOS EXCEPTION",QAOS1))
if QAOS1'>0!QAOSQUIT
QUIT
Begin DoDot:1
+3 SET QAOS=$GET(^QA(741.5,QAOS1,0))
+4 WRITE !?3,$PIECE(QAOS,"^",3)," ",$PIECE(QAOS,"^")
if $Y>(IOSL+QAOSLINE-3)
Begin DoDot:2
+5 KILL DIR
SET DIR(0)="E"
DO ^DIR
SET QAOSQUIT=$SELECT(Y'>0:1,1:0)
SET QAOSLINE=$Y
+6 QUIT
End DoDot:2
+7 QUIT
End DoDot:1
+8 WRITE !
SET QAOSQUIT=0
+9 QUIT
