CIMGAGPA.m

CIMGAGPA ; CMI/TUCSON/LAB - aberdeen area GPRA ;  [ 03/09/00  4:19 PM ]

 ;;1.0;ABERDEEN GPRA REPORT;;JAN 22, 2000

 ;

 ;

 W:$D(IOF) @IOF

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

INTRO ;

 D EXIT

DATES ;

 K CIMBD,CIMED,CIMPER

 S CIMQTR=0

 D Y

 I $D(CIMQUIT) D EXIT Q

 S CIMQY=""

 S DIR(0)="S^Q:One Quarter in FY "_$$FMTE^XLFDT(CIMPER)_";F:Full Fiscal Year",DIR("A")="Run the report for a",DIR("B")="Q" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) D EXIT Q

 S CIMQY=Y

 I CIMQY="Q" D Q I $D(CIMQUIT) G INTRO

ASU ;

 S CIMSUCNT=0

 S CIMRPTT=""

 S DIR(0)="S^A:AREA Aggregate;F:One Facility",DIR("A")="Run Report for",DIR("B")="A" KILL DA D ^DIR KILL DIR

 G:$D(DIRUT) DATES

 S CIMRPTT=Y

 I CIMRPTT="F" D  G:$D(CIMQUIT) ASU

 .S CIMSUCNT=0,CIMSU="",CIMSUC="" K CIMSUL

 .K CIMSUL S CIMX=0 F  S CIMX=$O(^CIMAGP(CIMX)) Q:CIMX'=+CIMX  S V=^CIMAGP(CIMX,0) I $P(V,U)=CIMBD,$P(V,U,2)=CIMED,$P(V,U,3)=CIMPER,$P(V,U,4)=CIMQTR S CIMSUL(CIMX)="",CIMSUCNT=CIMSUCNT+1

 .I '$D(CIMSUL) W !!,"No data from that time period has been uploaded from the service units.",! S CIMQUIT=1 Q

 .W !!,"Data from the following Facilities has been received.",!,"Please select the facility.",!

 .K CIMSUL1 S X=0,C=0 F  S X=$O(CIMSUL(X)) Q:X'=+X  S C=C+1,CIMSUL1(C)=X

 .S X=0 F  S X=$O(CIMSUL1(X)) Q:X'=+X  S CIM0=^CIMAGP(CIMSUL1(X),0) W !?2,X,")",?5,"FY: ",$$FMTE^XLFDT($P(CIM0,U,3)),?15,"QTR: ",$$VAL^XBDIQ1(19255.01,X,.04),?30,"SU: ",$$SU($P(CIM0,U,6)),?55,"Facility: ",$E($$FAC($P(CIM0,U,5)),1,15)

 .W !?2,"0)",?5,"None of the Above"

 .S DIR(0)="N^0:"_C_":0",DIR("A")="Please Select the Facility",DIR("B")="0" KILL DA D ^DIR KILL DIR

 .I $D(DIRUT) S CIMQUIT=1 Q

 .I 'Y S CIMQUIT=1 Q

 .K CIMSUL S CIMSUL(CIMSUL1(Y))="",CIMSUCNT=1,X=$P(^CIMAGP(CIMSUL1(Y),0),U,5),X=$O(^AUTTLOC("C",X,0)) I X S CIMSUNM=$P(^DIC(4,X,0),U)

 .Q

 G:CIMRPTT="F" ZIS

GETSU ;

 K CIMSUL S CIMX=0 F  S CIMX=$O(^CIMAGP(CIMX)) Q:CIMX'=+CIMX  S V=^CIMAGP(CIMX,0) I $P(V,U)=CIMBD,$P(V,U,2)=CIMED,$P(V,U,3)=CIMPER,$P(V,U,4)=CIMQTR S CIMSUL(CIMX)=""

 I '$D(CIMSUL) W !!,"No data from that time period has been uploaded from the service units.",! G INTRO

 W !!,"Data from the following Facilities has been received and will be used",!,"in the Area Aggregate Report:",!

 S X=0 F  S X=$O(CIMSUL(X)) Q:X'=+X  S CIM0=^CIMAGP(X,0) W !?5,"FY: ",$$FMTE^XLFDT($P(CIM0,U,3)),?15,"QTR: ",$$VAL^XBDIQ1(19255.01,X,.04),?30,"SU: ",$$SU($P(CIM0,U,6)),?55,"Facility: ",$E($$FAC($P(CIM0,U,5)),1,15)

ZIS ;call to XBDBQUE

 S CIMASUF=100090

 D ^XBFMK

 K DIC,DIADD,DLAYGO,DR,DA,DD,X,Y,DINUM

 S XBRP="PRINT^CIMGAGPB",XBRC="",XBRX="EXIT^CIMGAGPA",XBNS="CIM"

 D ^XBDBQUE

 D EXIT

 Q

 ;

FAC(S) ;

 NEW N S N=$O(^AUTTLOC("C",S,0))

 I N="" Q N

 Q $P(^DIC(4,N,0),U)

SU(S) ;

 NEW N S N=$O(^AUTTSU("C",S,0))

 I N="" Q N

 Q $P(^AUTTSU(N,0),U)

EXIT ;

 D EN^XBVK("CIM")

 D KILL^AUPNPAT

 D ^XBFMK

 Q

 ;

GETTAX ;

 K CIMTAX

 S CIMTAX=""

 S DIC="^ATXAX(",DIC(0)="AEMQ",DIC("A")="Enter the Name of the Community Taxonomy: " D ^DIC

 I Y=-1 Q

 S CIMX=+Y

 D SU1^CIMGAGP0

 Q

Q ;which quarter

 S DIR(0)="N^1:4:0",DIR("A")="Which Quarter" KILL DA D ^DIR KILL DIR

 I $D(DIRUT)!(Y="") S CIMQUIT="" Q

 S CIMQTR=Y

 I Y=1 S CIMBD=($E(CIMPER,1,3)-1)_"1001",CIMED=($E(CIMPER,1,3)-1)_"1231" Q

 I Y=2 S CIMBD=$E(CIMPER,1,3)_"0101",CIMED=$E(CIMPER,1,3)_"0331" Q

 I Y=3 S CIMBD=$E(CIMPER,1,3)_"0401",CIMED=$E(CIMPER,1,3)_"0630" Q

 I Y=4 S CIMBD=$E(CIMPER,1,3)_"0701",CIMED=$E(CIMPER,1,3)_"0930" Q

 Q

Y ;fiscal year

 W !

 S CIMVDT=""

 W !,"Enter the FY of interest.  Use a 4 digit year, e.g. 1999, 2000"

 S DIR(0)="D^::EP"

 S DIR("A")="Enter Fiscal year (e.g. 1999)"

 S DIR("?")="This report is compiled for a period.  Enter a valid date."

 D ^DIR

 K DIC

 If $D(DUOUT) S DIRUT=1 S CIMQUIT="" Q

 S CIMVDT=Y

 I $E(Y,4,7)'="0000" W !!,"Please enter a year only!",! G Y

 S CIMPER=CIMVDT,CIMBD=($E(CIMVDT,1,3)-1)_"1001",CIMED=$E(CIMVDT,1,3)_"0930"

 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")

 ;----------

LOC() ;EP - Return location name from file 4 based on DUZ(2).

 Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")

 ;----------

 ;

CIMGAGPA  ; CMI/TUCSON/LAB - aberdeen area GPRA ;  [ 03/09/00  4:19 PM ]

 +1       ;;1.0;ABERDEEN GPRA REPORT;;JAN 22, 2000

 +2       ;

 +3       ;

 +4        IF $DATA(IOF)

               WRITE @IOF

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

INTRO     ;

 +1        DO EXIT

DATES     ;

 +1        KILL CIMBD,CIMED,CIMPER

 +2        SET CIMQTR=0

 +3        DO Y

 +4        IF $DATA(CIMQUIT)

               DO EXIT

               QUIT 

 +5        SET CIMQY=""

 +6        SET DIR(0)="S^Q:One Quarter in FY "_$$FMTE^XLFDT(CIMPER)_";F:Full Fiscal Year"

           SET DIR("A")="Run the report for a"

           SET DIR("B")="Q"

           KILL DA

           DO ^DIR

           KILL DIR

 +7        IF $DATA(DIRUT)

               DO EXIT

               QUIT 

 +8        SET CIMQY=Y

 +9        IF CIMQY="Q"

               DO Q

               IF $DATA(CIMQUIT)

                   GOTO INTRO

ASU       ;

 +1        SET CIMSUCNT=0

 +2        SET CIMRPTT=""

 +3        SET DIR(0)="S^A:AREA Aggregate;F:One Facility"

           SET DIR("A")="Run Report for"

           SET DIR("B")="A"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               GOTO DATES

 +5        SET CIMRPTT=Y

 +6        IF CIMRPTT="F"

               Begin DoDot:1

 +7                SET CIMSUCNT=0

                   SET CIMSU=""

                   SET CIMSUC=""

                   KILL CIMSUL

 +8                KILL CIMSUL

                   SET CIMX=0

                   FOR 

                       SET CIMX=$ORDER(^CIMAGP(CIMX))

                       IF CIMX'=+CIMX

                           QUIT 

                       SET V=^CIMAGP(CIMX,0)

                       IF $PIECE(V,U)=CIMBD

                           IF $PIECE(V,U,2)=CIMED

                               IF $PIECE(V,U,3)=CIMPER

                                   IF $PIECE(V,U,4)=CIMQTR

                                       SET CIMSUL(CIMX)=""

                                       SET CIMSUCNT=CIMSUCNT+1

 +9                IF '$DATA(CIMSUL)

                       WRITE !!,"No data from that time period has been uploaded from the service units.",!

                       SET CIMQUIT=1

                       QUIT 

 +10               WRITE !!,"Data from the following Facilities has been received.",!,"Please select the facility.",!

 +11               KILL CIMSUL1

                   SET X=0

                   SET C=0

                   FOR 

                       SET X=$ORDER(CIMSUL(X))

                       IF X'=+X

                           QUIT 

                       SET C=C+1

                       SET CIMSUL1(C)=X

 +12               SET X=0

                   FOR 

                       SET X=$ORDER(CIMSUL1(X))

                       IF X'=+X

                           QUIT 

                       SET CIM0=^CIMAGP(CIMSUL1(X),0)

                       WRITE !?2,X,")",?5,"FY: ",$$FMTE^XLFDT($PIECE(CIM0,U,3)),?15,"QTR: ",$$VAL^XBDIQ1(19255.01,X,.04),?30,"SU: ",$$SU($PIECE(CIM0,U,6)),?55,"Facility: ",$EXTRACT($$FAC($PIECE(CIM0,U,5)),1,15)

 +13               WRITE !?2,"0)",?5,"None of the Above"

 +14               SET DIR(0)="N^0:"_C_":0"

                   SET DIR("A")="Please Select the Facility"

                   SET DIR("B")="0"

                   KILL DA

                   DO ^DIR

                   KILL DIR

 +15               IF $DATA(DIRUT)

                       SET CIMQUIT=1

                       QUIT 

 +16               IF 'Y

                       SET CIMQUIT=1

                       QUIT 

 +17               KILL CIMSUL

                   SET CIMSUL(CIMSUL1(Y))=""

                   SET CIMSUCNT=1

                   SET X=$PIECE(^CIMAGP(CIMSUL1(Y),0),U,5)

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

                   IF X

                       SET CIMSUNM=$PIECE(^DIC(4,X,0),U)

 +18               QUIT 

               End DoDot:1

               IF $DATA(CIMQUIT)

                   GOTO ASU

 +19       IF CIMRPTT="F"

               GOTO ZIS

GETSU     ;

 +1        KILL CIMSUL

           SET CIMX=0

           FOR 

               SET CIMX=$ORDER(^CIMAGP(CIMX))

               IF CIMX'=+CIMX

                   QUIT 

               SET V=^CIMAGP(CIMX,0)

               IF $PIECE(V,U)=CIMBD

                   IF $PIECE(V,U,2)=CIMED

                       IF $PIECE(V,U,3)=CIMPER

                           IF $PIECE(V,U,4)=CIMQTR

                               SET CIMSUL(CIMX)=""

 +2        IF '$DATA(CIMSUL)

               WRITE !!,"No data from that time period has been uploaded from the service units.",!

               GOTO INTRO

 +3        WRITE !!,"Data from the following Facilities has been received and will be used",!,"in the Area Aggregate Report:",!

 +4        SET X=0

           FOR 

               SET X=$ORDER(CIMSUL(X))

               IF X'=+X

                   QUIT 

               SET CIM0=^CIMAGP(X,0)

               WRITE !?5,"FY: ",$$FMTE^XLFDT($PIECE(CIM0,U,3)),?15,"QTR: ",$$VAL^XBDIQ1(19255.01,X,.04),?30,"SU: ",$$SU($PIECE(CIM0,U,6)),?55,"Facility: ",$EXTRACT($$FAC($PIECE(CIM0,U,5)),1,15)

ZIS       ;call to XBDBQUE

 +1        SET CIMASUF=100090

 +2        DO ^XBFMK

 +3        KILL DIC,DIADD,DLAYGO,DR,DA,DD,X,Y,DINUM

 +4        SET XBRP="PRINT^CIMGAGPB"

           SET XBRC=""

           SET XBRX="EXIT^CIMGAGPA"

           SET XBNS="CIM"

 +5        DO ^XBDBQUE

 +6        DO EXIT

 +7        QUIT 

 +8       ;

FAC(S)    ;

 +1        NEW N

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

 +2        IF N=""

               QUIT N

 +3        QUIT $PIECE(^DIC(4,N,0),U)

SU(S)     ;

 +1        NEW N

           SET N=$ORDER(^AUTTSU("C",S,0))

 +2        IF N=""

               QUIT N

 +3        QUIT $PIECE(^AUTTSU(N,0),U)

EXIT      ;

 +1        DO EN^XBVK("CIM")

 +2        DO KILL^AUPNPAT

 +3        DO ^XBFMK

 +4        QUIT 

 +5       ;

GETTAX    ;

 +1        KILL CIMTAX

 +2        SET CIMTAX=""

 +3        SET DIC="^ATXAX("

           SET DIC(0)="AEMQ"

           SET DIC("A")="Enter the Name of the Community Taxonomy: "

           DO ^DIC

 +4        IF Y=-1

               QUIT 

 +5        SET CIMX=+Y

 +6        DO SU1^CIMGAGP0

 +7        QUIT 

Q         ;which quarter

 +1        SET DIR(0)="N^1:4:0"

           SET DIR("A")="Which Quarter"

           KILL DA

           DO ^DIR

           KILL DIR

 +2        IF $DATA(DIRUT)!(Y="")

               SET CIMQUIT=""

               QUIT 

 +3        SET CIMQTR=Y

 +4        IF Y=1

               SET CIMBD=($EXTRACT(CIMPER,1,3)-1)_"1001"

               SET CIMED=($EXTRACT(CIMPER,1,3)-1)_"1231"

               QUIT 

 +5        IF Y=2

               SET CIMBD=$EXTRACT(CIMPER,1,3)_"0101"

               SET CIMED=$EXTRACT(CIMPER,1,3)_"0331"

               QUIT 

 +6        IF Y=3

               SET CIMBD=$EXTRACT(CIMPER,1,3)_"0401"

               SET CIMED=$EXTRACT(CIMPER,1,3)_"0630"

               QUIT 

 +7        IF Y=4

               SET CIMBD=$EXTRACT(CIMPER,1,3)_"0701"

               SET CIMED=$EXTRACT(CIMPER,1,3)_"0930"

               QUIT 

 +8        QUIT 

Y         ;fiscal year

 +1        WRITE !

 +2        SET CIMVDT=""

 +3        WRITE !,"Enter the FY of interest.  Use a 4 digit year, e.g. 1999, 2000"

 +4        SET DIR(0)="D^::EP"

 +5        SET DIR("A")="Enter Fiscal year (e.g. 1999)"

 +6        SET DIR("?")="This report is compiled for a period.  Enter a valid date."

 +7        DO ^DIR

 +8        KILL DIC

 +9        IF $DATA(DUOUT)

               SET DIRUT=1

               SET CIMQUIT=""

               QUIT 

 +10       SET CIMVDT=Y

 +11       IF $EXTRACT(Y,4,7)'="0000"

               WRITE !!,"Please enter a year only!",!

               GOTO Y

 +12       SET CIMPER=CIMVDT

           SET CIMBD=($EXTRACT(CIMVDT,1,3)-1)_"1001"

           SET CIMED=$EXTRACT(CIMVDT,1,3)_"0930"

 +13       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       ;----------

LOC()     ;EP - Return location name from file 4 based on DUZ(2).

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

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

 +3       ;