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