ASDCLA.m

ASDCLA ; IHS/ADC/PDW/ENM - LIST CLINIC ABBREVIATIONS ; [ 03/25/1999  11:48 AM ]

 ;;5.0;IHS SCHEDULING;;MAR 25, 1999

 ;

 S %ZIS="PQ" D ^%ZIS Q:POP  I $D(IO("Q")) D QUE Q

 ;

START ;EP; called by ztload

 U IO S ASDPG=0,ASDQ="" D HED

 S ASDA=0 F  S ASDA=$O(^SC("C",ASDA)) Q:ASDA=""!(ASDQ=U)  D

 . S ASDC=0 F  S ASDC=$O(^SC("C",ASDA,ASDC)) Q:ASDC=""!(ASDQ=U)  D

 .. Q:$P(^SC(ASDC,0),U,3)'["C"  Q:'$$ACTV^ASDUT(ASDC)

 .. I $Y>(IOSL-4) D NEWPG Q:ASDQ=U

 .. W !,ASDA,?10,$P(^SC(ASDC,0),U)

 ;

END ; eoj

 I IOST["C-",ASDQ'=U D PRTOPT^ASDVAR

 K ASDA,ASDC,ASDPG,ASDQ D ^%ZISC

 Q

 ;

QUE ; -- set ztload variables

 S ZTRTN="START^ASDCLA",ZTDESC="CLINIC ABBREV" D ^%ZTLOAD

 K ZTSK,IO("Q") D HOME^%ZIS Q

 ;

NEWPG ; end of page control

 I IOST'["C-" D HED Q

 K DIR S DIR(0)="E" D ^DIR S ASDQ=X

 I ASDQ'=U D HED

 Q

 ;

HED ; -- heading

 I (ASDPG>0)!(IOST["C-") W @IOF

 S ASDPG=ASDPG+1 W !!?25,"CLINIC ABBREVIATIONS",?70,"Page ",ASDPG

 W !,$$REPEAT^XLFSTR("=",80),!

 Q

ASDCLA    ; IHS/ADC/PDW/ENM - LIST CLINIC ABBREVIATIONS ; [ 03/25/1999  11:48 AM ]

 +1       ;;5.0;IHS SCHEDULING;;MAR 25, 1999

 +2       ;

 +3        SET %ZIS="PQ"

           DO ^%ZIS

           IF POP

               QUIT 

           IF $DATA(IO("Q"))

               DO QUE

               QUIT 

 +4       ;

START     ;EP; called by ztload

 +1        USE IO

           SET ASDPG=0

           SET ASDQ=""

           DO HED

 +2        SET ASDA=0

           FOR 

               SET ASDA=$ORDER(^SC("C",ASDA))

               IF ASDA=""!(ASDQ=U)

                   QUIT 

               Begin DoDot:1

 +3                SET ASDC=0

                   FOR 

                       SET ASDC=$ORDER(^SC("C",ASDA,ASDC))

                       IF ASDC=""!(ASDQ=U)

                           QUIT 

                       Begin DoDot:2

 +4                        IF $PIECE(^SC(ASDC,0),U,3)'["C"

                               QUIT 

                           IF '$$ACTV^ASDUT(ASDC)

                               QUIT 

 +5                        IF $Y>(IOSL-4)

                               DO NEWPG

                               IF ASDQ=U

                                   QUIT 

 +6                        WRITE !,ASDA,?10,$PIECE(^SC(ASDC,0),U)

                       End DoDot:2

               End DoDot:1

 +7       ;

END       ; eoj

 +1        IF IOST["C-"

               IF ASDQ'=U

                   DO PRTOPT^ASDVAR

 +2        KILL ASDA,ASDC,ASDPG,ASDQ

           DO ^%ZISC

 +3        QUIT 

 +4       ;

QUE       ; -- set ztload variables

 +1        SET ZTRTN="START^ASDCLA"

           SET ZTDESC="CLINIC ABBREV"

           DO ^%ZTLOAD

 +2        KILL ZTSK,IO("Q")

           DO HOME^%ZIS

           QUIT 

 +3       ;

NEWPG     ; end of page control

 +1        IF IOST'["C-"

               DO HED

               QUIT 

 +2        KILL DIR

           SET DIR(0)="E"

           DO ^DIR

           SET ASDQ=X

 +3        IF ASDQ'=U

               DO HED

 +4        QUIT 

 +5       ;

HED       ; -- heading

 +1        IF (ASDPG>0)!(IOST["C-")

               WRITE @IOF

 +2        SET ASDPG=ASDPG+1

           WRITE !!?25,"CLINIC ABBREVIATIONS",?70,"Page ",ASDPG

 +3        WRITE !,$$REPEAT^XLFSTR("=",80),!

 +4        QUIT