AQAOPV2.m

AQAOPV2 ; IHS/ORDC/LJF - PRINT PROVIDER QI CODES ;

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

 ;

 ;This rtn contians the user interface and call to DIP to print a

 ;listing of providers selected with their corresponding QI codes.

 ;

SINGLE ;display of selected provider codes

 D SINGLE^AQAOHPRV ;intro text

 K AQAOARR ;make sure array is empty to start

 S AQAOX=0 ;flag for first time thru

ASK ; >>> ask user for provider names to display

 K DIC S DIC=200,DIC(0)="AEQ",D="AK.PROVIDER",DIC("A")="Select "

 S DIC("A")=DIC("A")_$S('AQAOX:"PROVIDER NAME: ",1:"ANOTHER PROVIDER: ")

 S DIC("S")="I $P($G(^(""PS"")),U,4)=""""" ;screen out inactives

 D IX^DIC S AQAOX=1 G END:$D(DUOUT),END:$D(DTOUT),DEV:X="",DEV:Y=-1

 S AQAOARR(+Y)="" G ASK

 ;

DEV ; >>> get print device

 G END:'$D(AQAOARR) ;no providers selected

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

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

 K IO("Q") S ZTRTN="PRINT^AQAOPV2",ZTDESC="SINGLE PROV CODES"

 S ZTSAVE("AQAOARR(")="" D ^%ZTLOAD K ZTSK D ^%ZISC

 ;

 D PRTOPT^AQAOVAR G END

 ;

 ;

PRINT ; >>> loop thru selections and print data

 D INIT^AQAOUTIL S AQAOHCON="Provider",AQAOTY="PROVIDER QI CODES"

 D HEADING^AQAOUTIL,HEADING2 S AQAOX=0

 F  S AQAOX=$O(AQAOARR(AQAOX)) Q:AQAOX=""  Q:AQAOSTOP=U  D

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

 .K ^UTILITY("DIQ1",$J)

 .S DIC=200,DR=".01;53.5;9999999.039",DA=AQAOX D EN^DIQ1

 .W !!,"PROVIDER NAME:  ",$E($G(^UTILITY("DIQ1",$J,200,DA,.01)),1,25)

 .W ?45,"PROVIDER CLASS:  ",$E($G(^UTILITY("DIQ1",$J,200,DA,53.3)),1,18)

 .W !?6,"QI CODE:  ",AQAOX

 .W ?51,"PCC CODE:  ",$G(^UTILITY("DIQ1",$J,200,DA,9999999.039))

 ;

 I '$D(ZTQUEUED),(IOST["C-") D PRTOPT^AQAOVAR ;ask to  hit return

END ; >>> eoj

 K ^UTILITY("DIQ1",$J) D ^%ZISC D KILL^AQAOUTIL Q

 ;

 ;

HEADING2 ; >>> SUBRTN to print second half of heading

 W ?14,"(Please forward INACTIVE PROVIDER NAMES to proper dept.)"

 W !,AQAOLINE,! Q

AQAOPV2   ; IHS/ORDC/LJF - PRINT PROVIDER QI CODES ;

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

 +2       ;

 +3       ;This rtn contians the user interface and call to DIP to print a

 +4       ;listing of providers selected with their corresponding QI codes.

 +5       ;

SINGLE    ;display of selected provider codes

 +1       ;intro text

           DO SINGLE^AQAOHPRV

 +2       ;make sure array is empty to start

           KILL AQAOARR

 +3       ;flag for first time thru

           SET AQAOX=0

ASK       ; >>> ask user for provider names to display

 +1        KILL DIC

           SET DIC=200

           SET DIC(0)="AEQ"

           SET D="AK.PROVIDER"

           SET DIC("A")="Select "

 +2        SET DIC("A")=DIC("A")_$SELECT('AQAOX:"PROVIDER NAME: ",1:"ANOTHER PROVIDER: ")

 +3       ;screen out inactives

           SET DIC("S")="I $P($G(^(""PS"")),U,4)="""""

 +4        DO IX^DIC

           SET AQAOX=1

           IF $DATA(DUOUT)

               GOTO END

           IF $DATA(DTOUT)

               GOTO END

           IF X=""

               GOTO DEV

           IF Y=-1

               GOTO DEV

 +5        SET AQAOARR(+Y)=""

           GOTO ASK

 +6       ;

DEV       ; >>> get print device

 +1       ;no providers selected

           IF '$DATA(AQAOARR)

               GOTO END

 +2        WRITE !!

           SET %ZIS="QP"

           DO ^%ZIS

           IF POP

               GOTO END

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

               USE IO

               GOTO PRINT

 +4        KILL IO("Q")

           SET ZTRTN="PRINT^AQAOPV2"

           SET ZTDESC="SINGLE PROV CODES"

 +5        SET ZTSAVE("AQAOARR(")=""

           DO ^%ZTLOAD

           KILL ZTSK

           DO ^%ZISC

 +6       ;

 +7        DO PRTOPT^AQAOVAR

           GOTO END

 +8       ;

 +9       ;

PRINT     ; >>> loop thru selections and print data

 +1        DO INIT^AQAOUTIL

           SET AQAOHCON="Provider"

           SET AQAOTY="PROVIDER QI CODES"

 +2        DO HEADING^AQAOUTIL

           DO HEADING2

           SET AQAOX=0

 +3        FOR 

               SET AQAOX=$ORDER(AQAOARR(AQAOX))

               IF AQAOX=""

                   QUIT 

               IF AQAOSTOP=U

                   QUIT 

               Begin DoDot:1

 +4                IF $Y>(IOSL-4)

                       DO NEWPG^AQAOUTIL

                       IF AQAOSTOP=U

                           QUIT 

                       DO HEADING2

 +5                KILL ^UTILITY("DIQ1",$JOB)

 +6                SET DIC=200

                   SET DR=".01;53.5;9999999.039"

                   SET DA=AQAOX

                   DO EN^DIQ1

 +7                WRITE !!,"PROVIDER NAME:  ",$EXTRACT($GET(^UTILITY("DIQ1",$JOB,200,DA,.01)),1,25)

 +8                WRITE ?45,"PROVIDER CLASS:  ",$EXTRACT($GET(^UTILITY("DIQ1",$JOB,200,DA,53.3)),1,18)

 +9                WRITE !?6,"QI CODE:  ",AQAOX

 +10               WRITE ?51,"PCC CODE:  ",$GET(^UTILITY("DIQ1",$JOB,200,DA,9999999.039))

               End DoDot:1

 +11      ;

 +12      ;ask to  hit return

           IF '$DATA(ZTQUEUED)

               IF (IOST["C-")

                   DO PRTOPT^AQAOVAR

END       ; >>> eoj

 +1        KILL ^UTILITY("DIQ1",$JOB)

           DO ^%ZISC

           DO KILL^AQAOUTIL

           QUIT 

 +2       ;

 +3       ;

HEADING2  ; >>> SUBRTN to print second half of heading

 +1        WRITE ?14,"(Please forward INACTIVE PROVIDER NAMES to proper dept.)"

 +2        WRITE !,AQAOLINE,!

           QUIT