QAOSWRK0.m

QAOSWRK0 ;HISC/DAD-WORKSHEET DRIVER ROUTINE ;6/15/93  10:18

 ;;3.0;Occurrence Screen;;09/14/1993

 D HOME^%ZIS

ASKTYPE ;

 K DIR S DIR(0)="LO^1:4^K:X[""."" X",DIR("A")="Select Worksheet Type(s)"

 S DIR("?")="Select the type(s) of worksheet(s) you want printed, e.g., 1,2 or 1-4"

 S DIR("?",1)="Choose from:",DIR("?",2)="  1  Clinical worksheet"

 S DIR("?",3)="  2  Peer worksheet",DIR("?",4)="  3  Management worksheet"

 S DIR("?",5)="  4  Committee worksheet",DIR("?",6)=""

 W ! K DIRUT D ^DIR K DIR G:$D(DIRUT) EXIT S QAOSTYPE=$E(Y,1,$L(Y)-1)

ASKHOW ;

 K DIR S DIR(0)="SOB^1:Patient(s);2:Date Range;3:Blank"

 S DIR("A")="How do you want the worksheet(s) printed"

 S DIR("A",1)="Enter 1 to print the worksheet(s) for selected patient(s), or"

 S DIR("A",2)="Enter 2 to print the worksheet(s) for a range of dates, or"

 S DIR("A",3)="Enter 3 to print completely blank worksheets.",DIR("A",4)=""

 W ! K DIRUT D ^DIR K DIR G:$D(DIRUT) EXIT S QAOSHOW=Y,QAOSQUIT=0

 W:QAOSHOW=1 ! K ^TMP($J,"PATLIST") S (QAOSREC,QAOSQUIT,QAQQUIT)=0

 I QAOSHOW=3 D ASKCOPY G EXIT:QAOSQUIT,DEV

 D ^QAQDATE:QAOSHOW=2,ASKPAT:QAOSHOW=1 G EXIT:QAOSQUIT!QAQQUIT

ASKDATA ;

 K DIR S DIR(0)="SOB^1:Blank;2:With Data"

 S DIR("A")="Choose",DIR("A",1)="Enter 1 to print blank worksheets, or"

 S DIR("A",2)="Enter 2 to print worksheets for reviews currently in process/complete",DIR("A",3)="",DIR("B")=1

 W ! K DIRUT D ^DIR K DIR G:$D(DIRUT) EXIT S QAOSDATA=Y

DEV ;

 K %ZIS,IOP S %ZIS="QM" W ! D ^%ZIS G:POP EXIT

 I $D(IO("Q")) D  G EXIT

 . S ZTRTN="ENTSK^QAOSWRK0",ZTDESC="PRINT OCCURRENCE SCREEN WORKSHEETS"

 . S ZTSAVE("QAO*")="",ZTSAVE("QAQ*")="",ZTSAVE("^TMP($J,")=""

 . D ^%ZTLOAD

 . Q

ENTSK ;

 U IO D BLNKLOOP:QAOSHOW=3,DATELOOP:QAOSHOW=2,PATLOOP:QAOSHOW=1

EXIT ;

 W ! S IONOFF=1 D ^%ZISC K ^TMP($J,"PATLIST")

 K %ZIS,DIC,DIR,DIRUT,IONOFF,LOC,OCCDATE,PATNAM,POP,QA,QAOSD,QAOSDATA

 K QAOSDSEL,QAOSD0,QAOSHOW,QAOSQUIT,QAOSREC,QAOSTYPE,SCRN,X,Y,ZTDESC

 K ZTRTN,ZTSAVE,LEN,LOCDPT,LOCQA,REVR,DIW,DIWI,DIWT,DIWTC,DIWX,DN,I,Y,Z

 K QAOSMDUE,QAOSMDAY,HEADER,IEN405,LOC405,NAME,QAODC,QAODFN,QAODT,QAOSDFN

 K QAOSI,QAOSWHEN,QAOTS,SCREEN,SRV,SSN,UNDL,UNSC,WARD,QAOSCOPY,QAOCOPYS

 K QAOSONE,QAOSPDUE,QAOSPDAY,QAOSS0

 D KVAR^VADPT,K^QAQDATE S:$D(ZTQUEUED) ZTREQ="@"

 Q

ASKCOPY ;

 K DIR S DIR(0)="NAO^1:10:0"

 S DIR("A")="How many copies of each worksheet do you want: ",DIR("B")=1

 S DIR("?",1)="Enter the number of copies of each worksheet you want printed."

 S DIR("?")="Your answer must be from 1 to 10."

 W ! D ^DIR S QAOSQUIT=$S($D(DIRUT):1,$D(DIRUT):1,1:0),QAOCOPYS=Y

 Q

BLNKLOOP ;

 F QAOSCOPY=1:1:QAOCOPYS S (QAOSQUIT,QAOSD0)=0,QAOSDATA=1 D CALLROU

 Q

DATELOOP ;

 S QAOSQUIT=0 F QAOSD=QAQNBEG-.000001:0 S QAOSD=$O(^QA(741,"C",QAOSD)) Q:(QAOSD'>0)!(QAOSD>QAQNEND)!QAOSQUIT  F QAOSD0=0:0 S QAOSD0=$O(^QA(741,"C",QAOSD,QAOSD0)) Q:QAOSD0'>0!QAOSQUIT  D:$D(^QA(741,"AD",2,QAOSD0))[0 CALLROU

 Q

ASKPAT ;

 W !,$S(QAOSREC:"Another one: ",1:"Select PATIENT: ")

 R X:DTIME S:'$T X="^" S QAOSQUIT=$S(X="^":1,1:0)

 I X=""!QAOSQUIT S:'QAOSREC QAOSQUIT=1 Q

 I $E(X)="?" W @IOF,!!?3,"Select a patient by name or SSN.  To deselect a patient type a minus (-)",!?3,"sign and the patient name or SSN, e.g. -DOE,JOHN" D PATLIST

 S DIC="^QA(741,",DIC(0)="EMQ",DIC("S")="I $P(^(0),""^"",11)<2"

 S QAOSDSEL=0 S:$E(X)="-" QAOSDSEL=1,X=$E(X,2,999)

 D ^DIC K DIC("S") G:+Y=-1 ASKPAT

 I QAOSDSEL S:QAOSREC QAOSREC=QAOSREC-1 K ^TMP($J,"PATLIST",+Y)

 E  S QAOSREC=QAOSREC+1,^TMP($J,"PATLIST",+Y)=""

 G ASKPAT

PATLIST ;

 S QAOSQUIT=0 W:QAOSREC !!," YOU HAVE ALREADY SELECTED:"

 F QAOSD0=0:0 S QAOSD0=$O(^TMP($J,"PATLIST",QAOSD0)) Q:QAOSD0'>0!QAOSQUIT  D PATDISP

 W ! Q

PATDISP ;

 S LOC=^QA(741,QAOSD0,0),SCRN=+$G(^("SCRN"))

 S PATNAM=+LOC,PATNAM=$S($D(^DPT(PATNAM,0))#2:$P(^(0),"^"),1:PATNAM)

 S Y=$P(LOC,"^",3) X ^DD("DD") S OCCDATE=Y

 S SCRN=$S($D(^QA(741.1,SCRN,0))#2:+^(0),1:SCRN)

 W !?5,PATNAM,?30,OCCDATE,?50,SCRN

 I $Y>(IOSL-4) K DIR S DIR(0)="E" D ^DIR K DIR S QAOSQUIT=$S(Y'>0:1,1:0) I 'QAOSQUIT W:$O(^TMP($J,"PATLIST",QAOSD0))>0 @IOF,!," YOU HAVE ALREADY SELECTED:"

 Q

PATLOOP ;

 S QAOSQUIT=0 F QAOSD0=0:0 S QAOSD0=$O(^TMP($J,"PATLIST",QAOSD0)) Q:QAOSD0'>0!QAOSQUIT  D CALLROU

 Q

CALLROU ;

 D:QAOSTYPE["1" ^QAOSPCL0 Q:QAOSQUIT  D:QAOSTYPE["1" ^QAOSPCL1 Q:QAOSQUIT  D:QAOSTYPE["2" ^QAOSPPR0 Q:QAOSQUIT  D:QAOSTYPE["3" ^QAOSPMG0 Q:QAOSQUIT  D:QAOSTYPE["4" ^QAOSPCM0

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---QAOSWRK0   4395     printed  Feb 18, 2025@23:48:41                                                                                                                                                                                                    Page 2

QAOSWRK0  ;HISC/DAD-WORKSHEET DRIVER ROUTINE ;6/15/93  10:18

 +1       ;;3.0;Occurrence Screen;;09/14/1993

 +2        DO HOME^%ZIS

ASKTYPE   ;

 +1        KILL DIR

           SET DIR(0)="LO^1:4^K:X[""."" X"

           SET DIR("A")="Select Worksheet Type(s)"

 +2        SET DIR("?")="Select the type(s) of worksheet(s) you want printed, e.g., 1,2 or 1-4"

 +3        SET DIR("?",1)="Choose from:"

           SET DIR("?",2)="  1  Clinical worksheet"

 +4        SET DIR("?",3)="  2  Peer worksheet"

           SET DIR("?",4)="  3  Management worksheet"

 +5        SET DIR("?",5)="  4  Committee worksheet"

           SET DIR("?",6)=""

 +6        WRITE !

           KILL DIRUT

           DO ^DIR

           KILL DIR

           if $DATA(DIRUT)

               GOTO EXIT

           SET QAOSTYPE=$EXTRACT(Y,1,$LENGTH(Y)-1)

ASKHOW    ;

 +1        KILL DIR

           SET DIR(0)="SOB^1:Patient(s);2:Date Range;3:Blank"

 +2        SET DIR("A")="How do you want the worksheet(s) printed"

 +3        SET DIR("A",1)="Enter 1 to print the worksheet(s) for selected patient(s), or"

 +4        SET DIR("A",2)="Enter 2 to print the worksheet(s) for a range of dates, or"

 +5        SET DIR("A",3)="Enter 3 to print completely blank worksheets."

           SET DIR("A",4)=""

 +6        WRITE !

           KILL DIRUT

           DO ^DIR

           KILL DIR

           if $DATA(DIRUT)

               GOTO EXIT

           SET QAOSHOW=Y

           SET QAOSQUIT=0

 +7        if QAOSHOW=1

               WRITE !

           KILL ^TMP($JOB,"PATLIST")

           SET (QAOSREC,QAOSQUIT,QAQQUIT)=0

 +8        IF QAOSHOW=3

               DO ASKCOPY

               if QAOSQUIT

                   GOTO EXIT

               GOTO DEV

 +9        if QAOSHOW=2

               DO ^QAQDATE

           if QAOSHOW=1

               DO ASKPAT

           if QAOSQUIT!QAQQUIT

               GOTO EXIT

ASKDATA   ;

 +1        KILL DIR

           SET DIR(0)="SOB^1:Blank;2:With Data"

 +2        SET DIR("A")="Choose"

           SET DIR("A",1)="Enter 1 to print blank worksheets, or"

 +3        SET DIR("A",2)="Enter 2 to print worksheets for reviews currently in process/complete"

           SET DIR("A",3)=""

           SET DIR("B")=1

 +4        WRITE !

           KILL DIRUT

           DO ^DIR

           KILL DIR

           if $DATA(DIRUT)

               GOTO EXIT

           SET QAOSDATA=Y

DEV       ;

 +1        KILL %ZIS,IOP

           SET %ZIS="QM"

           WRITE !

           DO ^%ZIS

           if POP

               GOTO EXIT

 +2        IF $DATA(IO("Q"))

               Begin DoDot:1

 +3                SET ZTRTN="ENTSK^QAOSWRK0"

                   SET ZTDESC="PRINT OCCURRENCE SCREEN WORKSHEETS"

 +4                SET ZTSAVE("QAO*")=""

                   SET ZTSAVE("QAQ*")=""

                   SET ZTSAVE("^TMP($J,")=""

 +5                DO ^%ZTLOAD

 +6                QUIT 

               End DoDot:1

               GOTO EXIT

ENTSK     ;

 +1        USE IO

           if QAOSHOW=3

               DO BLNKLOOP

           if QAOSHOW=2

               DO DATELOOP

           if QAOSHOW=1

               DO PATLOOP

EXIT      ;

 +1        WRITE !

           SET IONOFF=1

           DO ^%ZISC

           KILL ^TMP($JOB,"PATLIST")

 +2        KILL %ZIS,DIC,DIR,DIRUT,IONOFF,LOC,OCCDATE,PATNAM,POP,QA,QAOSD,QAOSDATA

 +3        KILL QAOSDSEL,QAOSD0,QAOSHOW,QAOSQUIT,QAOSREC,QAOSTYPE,SCRN,X,Y,ZTDESC

 +4        KILL ZTRTN,ZTSAVE,LEN,LOCDPT,LOCQA,REVR,DIW,DIWI,DIWT,DIWTC,DIWX,DN,I,Y,Z

 +5        KILL QAOSMDUE,QAOSMDAY,HEADER,IEN405,LOC405,NAME,QAODC,QAODFN,QAODT,QAOSDFN

 +6        KILL QAOSI,QAOSWHEN,QAOTS,SCREEN,SRV,SSN,UNDL,UNSC,WARD,QAOSCOPY,QAOCOPYS

 +7        KILL QAOSONE,QAOSPDUE,QAOSPDAY,QAOSS0

 +8        DO KVAR^VADPT

           DO K^QAQDATE

           if $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +9        QUIT 

ASKCOPY   ;

 +1        KILL DIR

           SET DIR(0)="NAO^1:10:0"

 +2        SET DIR("A")="How many copies of each worksheet do you want: "

           SET DIR("B")=1

 +3        SET DIR("?",1)="Enter the number of copies of each worksheet you want printed."

 +4        SET DIR("?")="Your answer must be from 1 to 10."

 +5        WRITE !

           DO ^DIR

           SET QAOSQUIT=$SELECT($DATA(DIRUT):1,$DATA(DIRUT):1,1:0)

           SET QAOCOPYS=Y

 +6        QUIT 

BLNKLOOP  ;

 +1        FOR QAOSCOPY=1:1:QAOCOPYS

               SET (QAOSQUIT,QAOSD0)=0

               SET QAOSDATA=1

               DO CALLROU

 +2        QUIT 

DATELOOP  ;

 +1        SET QAOSQUIT=0

           FOR QAOSD=QAQNBEG-.000001:0

               SET QAOSD=$ORDER(^QA(741,"C",QAOSD))

               if (QAOSD'>0)!(QAOSD>QAQNEND)!QAOSQUIT

                   QUIT 

               FOR QAOSD0=0:0

                   SET QAOSD0=$ORDER(^QA(741,"C",QAOSD,QAOSD0))

                   if QAOSD0'>0!QAOSQUIT

                       QUIT 

                   if $DATA(^QA(741,"AD",2,QAOSD0))[0

                       DO CALLROU

 +2        QUIT 

ASKPAT    ;

 +1        WRITE !,$SELECT(QAOSREC:"Another one: ",1:"Select PATIENT: ")

 +2        READ X:DTIME

           if '$TEST

               SET X="^"

           SET QAOSQUIT=$SELECT(X="^":1,1:0)

 +3        IF X=""!QAOSQUIT

               if 'QAOSREC

                   SET QAOSQUIT=1

               QUIT 

 +4        IF $EXTRACT(X)="?"

               WRITE @IOF,!!?3,"Select a patient by name or SSN.  To deselect a patient type a minus (-)",!?3,"sign and the patient name or SSN, e.g. -DOE,JOHN"

               DO PATLIST

 +5        SET DIC="^QA(741,"

           SET DIC(0)="EMQ"

           SET DIC("S")="I $P(^(0),""^"",11)<2"

 +6        SET QAOSDSEL=0

           if $EXTRACT(X)="-"

               SET QAOSDSEL=1

               SET X=$EXTRACT(X,2,999)

 +7        DO ^DIC

           KILL DIC("S")

           if +Y=-1

               GOTO ASKPAT

 +8        IF QAOSDSEL

               if QAOSREC

                   SET QAOSREC=QAOSREC-1

               KILL ^TMP($JOB,"PATLIST",+Y)

 +9       IF '$TEST

               SET QAOSREC=QAOSREC+1

               SET ^TMP($JOB,"PATLIST",+Y)=""

 +10       GOTO ASKPAT

PATLIST   ;

 +1        SET QAOSQUIT=0

           if QAOSREC

               WRITE !!," YOU HAVE ALREADY SELECTED:"

 +2        FOR QAOSD0=0:0

               SET QAOSD0=$ORDER(^TMP($JOB,"PATLIST",QAOSD0))

               if QAOSD0'>0!QAOSQUIT

                   QUIT 

               DO PATDISP

 +3        WRITE !

           QUIT 

PATDISP   ;

 +1        SET LOC=^QA(741,QAOSD0,0)

           SET SCRN=+$GET(^("SCRN"))

 +2        SET PATNAM=+LOC

           SET PATNAM=$SELECT($DATA(^DPT(PATNAM,0))#2:$PIECE(^(0),"^"),1:PATNAM)

 +3        SET Y=$PIECE(LOC,"^",3)

           XECUTE ^DD("DD")

           SET OCCDATE=Y

 +4        SET SCRN=$SELECT($DATA(^QA(741.1,SCRN,0))#2:+^(0),1:SCRN)

 +5        WRITE !?5,PATNAM,?30,OCCDATE,?50,SCRN

 +6        IF $Y>(IOSL-4)

               KILL DIR

               SET DIR(0)="E"

               DO ^DIR

               KILL DIR

               SET QAOSQUIT=$SELECT(Y'>0:1,1:0)

               IF 'QAOSQUIT

                   if $ORDER(^TMP($JOB,"PATLIST",QAOSD0))>0

                       WRITE @IOF,!," YOU HAVE ALREADY SELECTED:"

 +7        QUIT 

PATLOOP   ;

 +1        SET QAOSQUIT=0

           FOR QAOSD0=0:0

               SET QAOSD0=$ORDER(^TMP($JOB,"PATLIST",QAOSD0))

               if QAOSD0'>0!QAOSQUIT

                   QUIT 

               DO CALLROU

 +2        QUIT 

CALLROU   ;

 +1        if QAOSTYPE["1"

               DO ^QAOSPCL0

           if QAOSQUIT

               QUIT 

           if QAOSTYPE["1"

               DO ^QAOSPCL1

           if QAOSQUIT

               QUIT 

           if QAOSTYPE["2"

               DO ^QAOSPPR0

           if QAOSQUIT

               QUIT 

           if QAOSTYPE["3"

               DO ^QAOSPMG0

           if QAOSQUIT

               QUIT 

           if QAOSTYPE["4"

               DO ^QAOSPCM0

 +2        QUIT