- 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
