AQAOUSM.m

AQAOUSM ; IHS/ORDC/LJF - PRINT TEAM MEMBER LIST ;

 ;;1.01;QAI MANAGEMENT;;OCT 05, 1995

 ;

 ;This rtn contains the user interface and print code to list members

 ;of a selected QI team.

 ;

TEAM ; >>> choose team to print

 W !! K DIC S DIC="^AQAO1(1,",DIC(0)="AEZMQ" D ^DIC G EXIT:Y=-1

 S AQAOTM=+Y,AQAOTMN=$P(Y,U,2)

 ;

DEV ; >>> get print device

 W !! S %ZIS="QP" D ^%ZIS G EXIT:POP

 I '$D(IO("Q")) U IO G CALC

 K IO("Q") S ZTRTN="CALC^AQAOUSM",ZTDESC="TEAM MEMBER LIST"

 S ZTSAVE("AQAOTM")="",ZTSAVE("AQAOTMN")=""

 D ^%ZTLOAD K ZTSK D ^%ZISC G EXIT

 ;

 ;

CALC ;ENTRY POINT called by ZTLOAD when report is queued

 ; >> for this team, find members and sort in alpha order

 K ^TMP("AQAOUSM",$J) S AQAOX=0

 F  S AQAOX=$O(^AQAO(9,"AB",AQAOTM,AQAOX)) Q:AQAOX=""  D

 .S AQAOY=0

 .F  S AQAOY=$O(^AQAO(9,"AB",AQAOTM,AQAOX,AQAOY)) Q:AQAOY=""  D

 ..Q:'$D(^AQAO(9,AQAOX,"TM",AQAOY,0))  S AQAOS=^(0)

 ..S X=$P(^VA(200,AQAOX,0),U) ;user name

 ..S ^TMP("AQAOUSM",$J,X,AQAOX)=$P(AQAOS,U,2) ;save in alpha order

 ;

PRINT ; >> take sorted list and print

 D INIT^AQAOUTIL S AQAOTY="QI TEAM MEMBERSHIP LIST" D HEADING^AQAOUTIL

 D HDG2

 S AQAOUSN=0

 F  S AQAOUSN=$O(^TMP("AQAOUSM",$J,AQAOUSN)) Q:AQAOUSN=""  Q:AQAOSTOP=U  D

 .S AQAOUSR=0

 .F  S AQAOUSR=$O(^TMP("AQAOUSM",$J,AQAOUSN,AQAOUSR)) Q:AQAOUSR=""  Q:AQAOSTOP=U  D

 ..S AQAOS=^TMP("AQAOUSM",$J,AQAOUSN,AQAOUSR)

 ..W !,$E(AQAOUSN,1,25) ;print member name

 ..S Y=$P(AQAOS,U),C=$P(^DD(9002168.91,.02,0),U,2) D Y^DIQ W ?45,Y

 ..I $Y>(IOSL-4) D NEWPG^AQAOUTIL Q:AQAOSTOP=U  D HDG2

 ;

EXIT ; >> eoj

 D ^%ZISC

 I '$D(ZTQUEUED) D PRTOPT^AQAOVAR

 D KILL^AQAOUTIL K ^TMP("AQAOUSM",$J) Q

 ;

 ;

HDG2 ; >> SUBRTN to print 2nd half of heading

 W ?AQAOIOMX-$L(AQAOTMN)/2,AQAOTMN,!,AQAOLINE

 W !,"Name",?45,"Pkg Access Level",!,AQAOLIN2,!

 Q

AQAOUSM   ; IHS/ORDC/LJF - PRINT TEAM MEMBER LIST ;

 +1       ;;1.01;QAI MANAGEMENT;;OCT 05, 1995

 +2       ;

 +3       ;This rtn contains the user interface and print code to list members

 +4       ;of a selected QI team.

 +5       ;

TEAM      ; >>> choose team to print

 +1        WRITE !!

           KILL DIC

           SET DIC="^AQAO1(1,"

           SET DIC(0)="AEZMQ"

           DO ^DIC

           IF Y=-1

               GOTO EXIT

 +2        SET AQAOTM=+Y

           SET AQAOTMN=$PIECE(Y,U,2)

 +3       ;

DEV       ; >>> get print device

 +1        WRITE !!

           SET %ZIS="QP"

           DO ^%ZIS

           IF POP

               GOTO EXIT

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

               USE IO

               GOTO CALC

 +3        KILL IO("Q")

           SET ZTRTN="CALC^AQAOUSM"

           SET ZTDESC="TEAM MEMBER LIST"

 +4        SET ZTSAVE("AQAOTM")=""

           SET ZTSAVE("AQAOTMN")=""

 +5        DO ^%ZTLOAD

           KILL ZTSK

           DO ^%ZISC

           GOTO EXIT

 +6       ;

 +7       ;

CALC      ;ENTRY POINT called by ZTLOAD when report is queued

 +1       ; >> for this team, find members and sort in alpha order

 +2        KILL ^TMP("AQAOUSM",$JOB)

           SET AQAOX=0

 +3        FOR 

               SET AQAOX=$ORDER(^AQAO(9,"AB",AQAOTM,AQAOX))

               IF AQAOX=""

                   QUIT 

               Begin DoDot:1

 +4                SET AQAOY=0

 +5                FOR 

                       SET AQAOY=$ORDER(^AQAO(9,"AB",AQAOTM,AQAOX,AQAOY))

                       IF AQAOY=""

                           QUIT 

                       Begin DoDot:2

 +6                        IF '$DATA(^AQAO(9,AQAOX,"TM",AQAOY,0))

                               QUIT 

                           SET AQAOS=^(0)

 +7       ;user name

                           SET X=$PIECE(^VA(200,AQAOX,0),U)

 +8       ;save in alpha order

                           SET ^TMP("AQAOUSM",$JOB,X,AQAOX)=$PIECE(AQAOS,U,2)

                       End DoDot:2

               End DoDot:1

 +9       ;

PRINT     ; >> take sorted list and print

 +1        DO INIT^AQAOUTIL

           SET AQAOTY="QI TEAM MEMBERSHIP LIST"

           DO HEADING^AQAOUTIL

 +2        DO HDG2

 +3        SET AQAOUSN=0

 +4        FOR 

               SET AQAOUSN=$ORDER(^TMP("AQAOUSM",$JOB,AQAOUSN))

               IF AQAOUSN=""

                   QUIT 

               IF AQAOSTOP=U

                   QUIT 

               Begin DoDot:1

 +5                SET AQAOUSR=0

 +6                FOR 

                       SET AQAOUSR=$ORDER(^TMP("AQAOUSM",$JOB,AQAOUSN,AQAOUSR))

                       IF AQAOUSR=""

                           QUIT 

                       IF AQAOSTOP=U

                           QUIT 

                       Begin DoDot:2

 +7                        SET AQAOS=^TMP("AQAOUSM",$JOB,AQAOUSN,AQAOUSR)

 +8       ;print member name

                           WRITE !,$EXTRACT(AQAOUSN,1,25)

 +9                        SET Y=$PIECE(AQAOS,U)

                           SET C=$PIECE(^DD(9002168.91,.02,0),U,2)

                           DO Y^DIQ

                           WRITE ?45,Y

 +10                       IF $Y>(IOSL-4)

                               DO NEWPG^AQAOUTIL

                               IF AQAOSTOP=U

                                   QUIT 

                               DO HDG2

                       End DoDot:2

               End DoDot:1

 +11      ;

EXIT      ; >> eoj

 +1        DO ^%ZISC

 +2        IF '$DATA(ZTQUEUED)

               DO PRTOPT^AQAOVAR

 +3        DO KILL^AQAOUTIL

           KILL ^TMP("AQAOUSM",$JOB)

           QUIT 

 +4       ;

 +5       ;

HDG2      ; >> SUBRTN to print 2nd half of heading

 +1        WRITE ?AQAOIOMX-$LENGTH(AQAOTMN)/2,AQAOTMN,!,AQAOLINE

 +2        WRITE !,"Name",?45,"Pkg Access Level",!,AQAOLIN2,!

 +3        QUIT