APCLCAR.m

APCLCAR ; IHS/CMI/LAB - california area GPRA ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ;

 ;

 W:$D(IOF) @IOF

 W !!,$$CTR("California Annual Utilization Report of Primary Care Clinics",80)

INTRO ;

 W !!,"This report will provide data for the California State Annual Utilization",!,"Report of Primary Care Clinics",!

 W !,$$CTR("Updated for the 2008 Report",80),!!

 D EXIT

Y ;fiscal year

 K DIR

 S APCLVDT=""

 W !,"Enter the Calender Year of interest.  Use a 4 digit year, e.g. 2008, 2007"

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

 S DIR("A")="Enter Calendar year (e.g. 2008)"

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

 D ^DIR

 K DIC

 I $D(DUOUT) S DIRUT=1 G EXIT

 S APCLVDT=Y

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

VLOC ;get visit location of encounter

 K APCLLOC,APCLLOCT

 W ! S DIR(0)="YO",DIR("A")="Include visits from ALL Locations",DIR("B")="Yes"

 S DIR("?")="If you wish to include visits from ALL locations answer Yes.  If you wish to list visits for only one location of encounter enter NO."

 D ^DIR K DIR

 G:$D(DIRUT) Y

 I Y=1 G CHKTAX

LOC1 ;enter location

 S X="LOCATION OF ENCOUNTER",DIC="^AMQQ(5,",DIC(0)="FM",DIC("S")="I $P(^(0),U,14)" D ^DIC K DIC,DA I Y=-1 W "OOPS - QMAN NOT CURRENT - QUITTING" G EXIT

 D PEP^AMQQGTX0(+Y,"APCLLOCT(")

 I '$D(APCLLOCT) G VLOC

 I $D(APCLLOCT("*")) K APCLLOCT

CHKTAX ;check taxonomies

 S APCLQ=0

 S APCLPER=APCLVDT,APCLBD=$E(APCLVDT,1,3)_"0101",APCLED=$E(APCLVDT,1,3)_"1231"

 F X=60:1:70,74,80:1:90,94 S APCLT="APCL CAR L"_X S Y="APCL"_X_"T" S @Y=$O(^ATXAX("B",APCLT,0))

 I APCLQ W !!,"Cannot continue.  Taxonomies not in place." Q

FEE ;

 W !!,"Please enter the FEE Schedule to use in calculating the primary cpt code.",!

 S DIC="^ABMDFEE(",DIC(0)="AEMQ" D ^DIC

 I Y=-1 S APCLFEE="" G VLOC

 S APCLFEE=+Y

CPTL ;

 S APCLCPTR=""

 S DIR(0)="Y",DIR("A")="Do you want to include a list of visits with no cpt code",DIR("B")="N" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) G FEE

 I Y S APCLCPTR=1

ZIS ;

DEMO ;

 D DEMOCHK^APCLUTL(.APCLDEMO)

 I APCLDEMO=-1 G CPTL

 S XBRP="PRINT^APCLCARP",XBRC="PROC^APCLCAR1",XBRX="EXIT^APCLCAR",XBNS="APCL"

 D ^XBDBQUE

 D EXIT

 Q

 ;

EXIT ;

 K A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,W,X,Y,Z

 K %,%1

 D EN^XBVK("APCL")

 D KILL^AUPNPAT

 D ^XBFMK

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

 ;----------

APCLCAR   ; IHS/CMI/LAB - california area GPRA ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;

 +3       ;

 +4        IF $DATA(IOF)

               WRITE @IOF

 +5        WRITE !!,$$CTR("California Annual Utilization Report of Primary Care Clinics",80)

INTRO     ;

 +1        WRITE !!,"This report will provide data for the California State Annual Utilization",!,"Report of Primary Care Clinics",!

 +2        WRITE !,$$CTR("Updated for the 2008 Report",80),!!

 +3        DO EXIT

Y         ;fiscal year

 +1        KILL DIR

 +2        SET APCLVDT=""

 +3        WRITE !,"Enter the Calender Year of interest.  Use a 4 digit year, e.g. 2008, 2007"

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

 +5        SET DIR("A")="Enter Calendar year (e.g. 2008)"

 +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

               GOTO EXIT

 +10       SET APCLVDT=Y

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

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

               GOTO Y

VLOC      ;get visit location of encounter

 +1        KILL APCLLOC,APCLLOCT

 +2        WRITE !

           SET DIR(0)="YO"

           SET DIR("A")="Include visits from ALL Locations"

           SET DIR("B")="Yes"

 +3        SET DIR("?")="If you wish to include visits from ALL locations answer Yes.  If you wish to list visits for only one location of encounter enter NO."

 +4        DO ^DIR

           KILL DIR

 +5        IF $DATA(DIRUT)

               GOTO Y

 +6        IF Y=1

               GOTO CHKTAX

LOC1      ;enter location

 +1        SET X="LOCATION OF ENCOUNTER"

           SET DIC="^AMQQ(5,"

           SET DIC(0)="FM"

           SET DIC("S")="I $P(^(0),U,14)"

           DO ^DIC

           KILL DIC,DA

           IF Y=-1

               WRITE "OOPS - QMAN NOT CURRENT - QUITTING"

               GOTO EXIT

 +2        DO PEP^AMQQGTX0(+Y,"APCLLOCT(")

 +3        IF '$DATA(APCLLOCT)

               GOTO VLOC

 +4        IF $DATA(APCLLOCT("*"))

               KILL APCLLOCT

CHKTAX    ;check taxonomies

 +1        SET APCLQ=0

 +2        SET APCLPER=APCLVDT

           SET APCLBD=$EXTRACT(APCLVDT,1,3)_"0101"

           SET APCLED=$EXTRACT(APCLVDT,1,3)_"1231"

 +3        FOR X=60:1:70,74,80:1:90,94

               SET APCLT="APCL CAR L"_X

               SET Y="APCL"_X_"T"

               SET @Y=$ORDER(^ATXAX("B",APCLT,0))

 +4        IF APCLQ

               WRITE !!,"Cannot continue.  Taxonomies not in place."

               QUIT 

FEE       ;

 +1        WRITE !!,"Please enter the FEE Schedule to use in calculating the primary cpt code.",!

 +2        SET DIC="^ABMDFEE("

           SET DIC(0)="AEMQ"

           DO ^DIC

 +3        IF Y=-1

               SET APCLFEE=""

               GOTO VLOC

 +4        SET APCLFEE=+Y

CPTL      ;

 +1        SET APCLCPTR=""

 +2        SET DIR(0)="Y"

           SET DIR("A")="Do you want to include a list of visits with no cpt code"

           SET DIR("B")="N"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO FEE

 +4        IF Y

               SET APCLCPTR=1

ZIS       ;

DEMO      ;

 +1        DO DEMOCHK^APCLUTL(.APCLDEMO)

 +2        IF APCLDEMO=-1

               GOTO CPTL

 +3        SET XBRP="PRINT^APCLCARP"

           SET XBRC="PROC^APCLCAR1"

           SET XBRX="EXIT^APCLCAR"

           SET XBNS="APCL"

 +4        DO ^XBDBQUE

 +5        DO EXIT

 +6        QUIT 

 +7       ;

EXIT      ;

 +1        KILL A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,W,X,Y,Z

 +2        KILL %,%1

 +3        DO EN^XBVK("APCL")

 +4        DO KILL^AUPNPAT

 +5        DO ^XBFMK

 +6        QUIT 

 +7       ;

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