QAOEDT0.m

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 ---QAOEDT0   4634     printed  Apr 23, 2025@18:35:39                                                                                                                                                                                                     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