- 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 Feb 18, 2025@23:47:35 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