CIMGAGPJ.m

CIMGAGPJ ;IHS/CMI/LAB - cover page for gpra area [ 03/14/00  8:52 PM ]

 ;

 ;

 S CIMGPG=0 D HEADER

 W !!?1,"Report includes the following facility data:"

 NEW CIMX

 S CIMX="" F  S CIMX=$O(CIMSUL(CIMX)) Q:CIMX=""  D

 .I $Y>(IOSL-5) D EOP W:$D(IOF) @IOF

 .S X=$P(^CIMAGP(CIMX,0),U,5),X=$O(^AUTTLOC("C",X,0)) S X=$S(X:$P(^DIC(4,X,0),U),1:"?????")

 .W !?3,X

 .W !?5,"Communities: " S X=0,N=0,Y="" F  S X=$O(^CIMAGP(CIMX,28,X)) Q:X'=+X  S N=N+1,Y=Y_$S(N=1:"",1:";")_$P(^CIMAGP(CIMX,28,X,0),U)

 .S X=0,C=0 F X=1:3:N W !?10,$E($P(Y,";",X),1,20),?30,$E($P(Y,";",(X+1)),1,20),?60,$E($P(Y,";",(X+2)),1,20)

 .Q

 K CIMX,CIMQUIT

 Q

HEADER ;EP

 G:'CIMGPG HEADER1

 K DIR I $E(IOST)="C",IO=IO(0),'$D(ZTQUEUED) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S CIMQUIT=1 Q

HEADER1 ;

 W:$D(IOF) @IOF S CIMGPG=CIMGPG+1

 W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",CIMGPG,!

 W !,$$CTR("Aberdeen Area GPRA Report")

 W !,$$CTR("Area AGGREGATE Report")

 S X="Reporting Period: "_$$FMTE^XLFDT(CIMBD)_" to "_$$FMTE^XLFDT(CIMED) W !,$$CTR(X,80)

 S X="Baseline Period:  "_$$FMTE^XLFDT(CIM98B)_" to "_$$FMTE^XLFDT(CIM98E) W !,$$CTR(X,80)

 Q

CTR(X,Y) ;EP - Center X in a field Y wide.

 Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X

 ;----------

EOP ;EP - End of page.

 Q:$E(IOST)'="C"

 Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))

 NEW DIR

 K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT

 S DIR(0)="E" D ^DIR

 Q

 ;----------

USR() ;EP - Return name of current user from ^VA(200.

 Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")

 ;----------

CIMGAGPJ  ;IHS/CMI/LAB - cover page for gpra area [ 03/14/00  8:52 PM ]

 +1       ;

 +2       ;

 +3        SET CIMGPG=0

           DO HEADER

 +4        WRITE !!?1,"Report includes the following facility data:"

 +5        NEW CIMX

 +6        SET CIMX=""

           FOR 

               SET CIMX=$ORDER(CIMSUL(CIMX))

               IF CIMX=""

                   QUIT 

               Begin DoDot:1

 +7                IF $Y>(IOSL-5)

                       DO EOP

                       IF $DATA(IOF)

                           WRITE @IOF

 +8                SET X=$PIECE(^CIMAGP(CIMX,0),U,5)

                   SET X=$ORDER(^AUTTLOC("C",X,0))

                   SET X=$SELECT(X:$PIECE(^DIC(4,X,0),U),1:"?????")

 +9                WRITE !?3,X

 +10               WRITE !?5,"Communities: "

                   SET X=0

                   SET N=0

                   SET Y=""

                   FOR 

                       SET X=$ORDER(^CIMAGP(CIMX,28,X))

                       IF X'=+X

                           QUIT 

                       SET N=N+1

                       SET Y=Y_$SELECT(N=1:"",1:";")_$PIECE(^CIMAGP(CIMX,28,X,0),U)

 +11               SET X=0

                   SET C=0

                   FOR X=1:3:N

                       WRITE !?10,$EXTRACT($PIECE(Y,";",X),1,20),?30,$EXTRACT($PIECE(Y,";",(X+1)),1,20),?60,$EXTRACT($PIECE(Y,";",(X+2)),1,20)

 +12               QUIT 

               End DoDot:1

 +13       KILL CIMX,CIMQUIT

 +14       QUIT 

HEADER    ;EP

 +1        IF 'CIMGPG

               GOTO HEADER1

 +2        KILL DIR

           IF $EXTRACT(IOST)="C"

               IF IO=IO(0)

                   IF '$DATA(ZTQUEUED)

                       WRITE !

                       SET DIR(0)="EO"

                       DO ^DIR

                       KILL DIR

                       IF Y=0!(Y="^")!($DATA(DTOUT))

                           SET CIMQUIT=1

                           QUIT 

HEADER1   ;

 +1        IF $DATA(IOF)

               WRITE @IOF

           SET CIMGPG=CIMGPG+1

 +2        WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",CIMGPG,!

 +3        WRITE !,$$CTR("Aberdeen Area GPRA Report")

 +4        WRITE !,$$CTR("Area AGGREGATE Report")

 +5        SET X="Reporting Period: "_$$FMTE^XLFDT(CIMBD)_" to "_$$FMTE^XLFDT(CIMED)

           WRITE !,$$CTR(X,80)

 +6        SET X="Baseline Period:  "_$$FMTE^XLFDT(CIM98B)_" to "_$$FMTE^XLFDT(CIM98E)

           WRITE !,$$CTR(X,80)

 +7        QUIT 

CTR(X,Y)  ;EP - Center X in a field Y wide.

 +1        QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X

 +2       ;----------

EOP       ;EP - End of page.

 +1        IF $EXTRACT(IOST)'="C"

               QUIT 

 +2        IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))

               QUIT 

 +3        NEW DIR

 +4        KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT

 +5        SET DIR(0)="E"

           DO ^DIR

 +6        QUIT 

 +7       ;----------

USR()     ;EP - Return name of current user from ^VA(200.

 +1        QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")

 +2       ;----------