APCLPP2 ; IHS/CMI/LAB - ; 23 May 2014 10:44 AM
;;2.0;IHS PCC SUITE;**7,11**;MAY 14, 2009;Build 58
;
;
START ;
D XIT
S APCLJOB=$J,APCLBTH=$H
K ^XTMP("APCLPP2",APCLJOB,APCLBTH)
D INFORM
GETDATES ;
BD ;
W !!,"Enter the time frame of interest.",! S DIR(0)="D^::EP",DIR("A")="Enter Beginning Visit Date",DIR("?")="Enter the beginning visit date for the search." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
G:$D(DIRUT) XIT
S APCLBD=Y
ED ;
S DIR(0)="DA^::EP",DIR("A")="Enter Ending Visit Date: " D ^DIR K DIR S:$D(DUOUT) DIRUT=1
G:$D(DIRUT) XIT
I Y<APCLBD W !,"Ending date must be greater than or equal to beginning date!" G ED
S APCLED=Y
S X1=APCLBD,X2=-1 D C^%DTC S APCLSD=X
PROV ;
K APCLPROV,APCLPRVN,APCLPRVD
S APCLPT=""
S DIR(0)="S^O:ONE Provider;C:COHORT or Selected Set of Providers",DIR("A")="Prepare report for",DIR("B")="O" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G GETDATES
S APCLPT=Y
I APCLPT="C" G PROVC
PROV1 ;
S DIC("A")="Prepare report for which PROVIDER: ",DIC=$S($P(^DD(9000001,.14,0),U,2)[200:"^VA(200,",1:"^DIC(6,"),DIC(0)="AEMQ" D ^DIC K DIC,DA G:Y<0 GETDATES
S APCLPROV(+Y)="",APCLPRVN(+Y)=$S($P(^DD(9000001,.14,0),U,2)[200:$P(^VA(200,+Y,0),U),1:$P(^DIC(16,+Y,0),U))
S APCLPRVD(+Y)=$$VAL^XBDIQ1($S($P(^DD(9000001,.14,0),U,2)[200:200,1:6),+Y,$S($P(^DD(9000001,.14,0),U,2)[200:53.5,1:2))
G FAC
PROVC ;cohort
K APCLPROV,APCLPRVN,APCLPRVD
S X="PRIMARY PROVIDER",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 XIT
D PEP^AMQQGTX0(+Y,"APCLPROV(")
I '$D(APCLPROV) G PROV
I $D(APCLPROV("*")) W !,"all not allowed with this report" K APCLPROV G PROV
S Y=0 F S Y=$O(APCLPROV(Y)) Q:Y'=+Y D
.S APCLPROV(Y)="",APCLPRVN(Y)=$S($P(^DD(9000001,.14,0),U,2)[200:$P(^VA(200,Y,0),U),1:$P(^DIC(16,Y,0),U))
.S APCLPRVD(Y)=$$VAL^XBDIQ1($S($P(^DD(9000001,.14,0),U,2)[200:200,1:6),Y,$S($P(^DD(9000001,.14,0),U,2)[200:53.5,1:2))
FAC ;
S APCLSUH=""
W !!,"For use in reporting Hospital and In-Hospital information, please enter",!,"your Service Unit's Hospital. If there is no hospital in your service unit",!,"press ENTER to bypass the prompt.",!
S DIC(0)="AEMQ",DIC="^AUTTLOC(" D ^DIC
I X="" G LS
I ($D(DUOUT))!($D(DTOUT)) G PROV
I Y=-1 G FAC
S APCLSUH=+Y
LS ;
S APCLLSV=""
S DIR(0)="S^L:Long Version (10 items in each list);S:Short Version (5 items in each list)",DIR("A")="Which Report would you like"
S DIR("B")="S" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G FAC
S APCLLSV=Y
EXCL ;exclude any diagnoses codes?
K APCLEXCL,APCLDXT
W !!,"In the list of leading purpose of visits you have the option of excluding ",!,"certain ICD diagnoses from the list of top ten diagnoses.",!
S APCLEXCL=""
W !,"Do you wish to exclude any diagnoses codes from the list of "
S DIR(0)="Y",DIR("A")="top "_$S(APCLLSV="L":10,1:5)_" Purpose of Visits",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G LS
S APCLEXCL=Y
EXCL1 ;which ones to exclude
K APCLDXT
I 'APCLEXCL G ZIS
W !,"Enter the diagnoses to be excluded.",!
DX1 ;
S X="DIAGNOSIS",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 XIT
D PEP^AMQQGTX0(+Y,"APCLDXT(")
I '$D(APCLDXT) G EXCL
I $D(APCLDXT("*")) K APCLDXT
ZIS ;
ST ;;template of patients?
S APCLSEAT=""
S DIR(0)="S^A:ALL PATIENTS;S:SEARCH TEMPLATE OF PATIENTS",DIR("A")="Which set of patients should be included in this report",DIR("B")="A" KILL DA D ^DIR KILL DIR
G:$D(DIRUT) EXCL
I Y="A" G DEMO
S APCLSEAT=""
;
W ! S DIC("S")="I $P(^(0),U,4)=9000001" S DIC="^DIBT(",DIC("A")="Enter Patient SEARCH TEMPLATE name: ",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DICR
I Y=-1 S APCLSEAT="" G ST
S APCLSEAT=+Y
DEMO ;
D DEMOCHK^APCLUTL(.APCLDEMO)
I APCLDEMO=-1 G EXCL
S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to ",DIR("B")="P" K DA D ^DIR K DIR
I $D(DIRUT) G XIT
I $G(Y)="B" D BROWSE,XIT Q
S XBRP="^APCLPP2P",XBRC="^APCLPP21",XBNS="APCL",XBRX="XIT^APCLPP2"
D ^XBDBQUE
Q
;
XIT ;
D EN^XBVK("APCL")
D KILL^AUPNPAT
D ^XBFMK
Q
BROWSE ;
S XBRP="VIEWR^XBLM(""^APCLPP2P"")"
S XBNS="APCL",XBRC="^APCLPP21",XBRX="XIT^APCLPP2",XBIOP=0 D ^XBDBQUE
Q
;
INFORM ;tell user what is going on
W:$D(IOF) @IOF
W $$CTR("************* PROVIDER PRACTICE DESCRIPTION REPORT ************",80)
W !!,"This report will present a profile of services provided by a selected provider."
W !,"You will be asked to enter a date range and to identify the provider's name.",!
Q
SET ;EP - ENTRY POINT
S APCLC=0 F S APCLC=$O(APCLPROV(APCLC)) Q:APCLC'=+APCLC D SETC
Q
SETC ;
S APCL4="REPORT",APCL1="COMMC",APCL3="COMM" D SET1
S APCL4="REPORT",APCL1="TRIBEC",APCL3="TRIBE" D SET1
S APCL4="REPORT",APCL1="SCC",APCL3="SC" D SET1
S APCL4="REPORT",APCL1="LOCC",APCL3="LOC" D SET1
S APCL4="REPORT",APCL1="OUTDXC",APCL3="OUTDX" D SET1
S APCL4="REPORT",APCL1="INPTDXC",APCL3="INPTDX" D SET1
S APCL4="REPORT",APCL1="PATEDC",APCL3="PATED" D SET1
S APCL4="REPORT",APCL1="SURGPROCC",APCL3="SURGPROC" D SET1
S APCL4="REPORT",APCL1="RXC",APCL3="RX" D SET1
S APCL4="REPORT",APCL1="EMC",APCL3="EM" D SET1
S APCL4="REPORT",APCL1="INPTSURGPROCC",APCL3="INPTSURGPROC" D SET1
Q
SET1 ;
S APCL2="^XTMP(""APCLPP2"",APCLJOB,APCLBTH,""RP"","""_APCLC_""","""_APCL4_""","""_APCL3_""",X)"
S X="" F S X=$O(@APCL2) Q:X="" S %=^(X) S ^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLC,APCL4,APCL1,9999999-%,X)=%
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("A")="End of Report. Press return",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")
;----------
;
APCLPP2 ; IHS/CMI/LAB - ; 23 May 2014 10:44 AM
+1 ;;2.0;IHS PCC SUITE;**7,11**;MAY 14, 2009;Build 58
+2 ;
+3 ;
START ;
+1 DO XIT
+2 SET APCLJOB=$JOB
SET APCLBTH=$HOROLOG
+3 KILL ^XTMP("APCLPP2",APCLJOB,APCLBTH)
+4 DO INFORM
GETDATES ;
BD ;
+1 WRITE !!,"Enter the time frame of interest.",!
SET DIR(0)="D^::EP"
SET DIR("A")="Enter Beginning Visit Date"
SET DIR("?")="Enter the beginning visit date for the search."
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO XIT
+3 SET APCLBD=Y
ED ;
+1 SET DIR(0)="DA^::EP"
SET DIR("A")="Enter Ending Visit Date: "
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO XIT
+3 IF Y<APCLBD
WRITE !,"Ending date must be greater than or equal to beginning date!"
GOTO ED
+4 SET APCLED=Y
+5 SET X1=APCLBD
SET X2=-1
DO C^%DTC
SET APCLSD=X
PROV ;
+1 KILL APCLPROV,APCLPRVN,APCLPRVD
+2 SET APCLPT=""
+3 SET DIR(0)="S^O:ONE Provider;C:COHORT or Selected Set of Providers"
SET DIR("A")="Prepare report for"
SET DIR("B")="O"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO GETDATES
+5 SET APCLPT=Y
+6 IF APCLPT="C"
GOTO PROVC
PROV1 ;
+1 SET DIC("A")="Prepare report for which PROVIDER: "
SET DIC=$SELECT($PIECE(^DD(9000001,.14,0),U,2)[200:"^VA(200,",1:"^DIC(6,")
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA
IF Y<0
GOTO GETDATES
+2 SET APCLPROV(+Y)=""
SET APCLPRVN(+Y)=$SELECT($PIECE(^DD(9000001,.14,0),U,2)[200:$PIECE(^VA(200,+Y,0),U),1:$PIECE(^DIC(16,+Y,0),U))
+3 SET APCLPRVD(+Y)=$$VAL^XBDIQ1($SELECT($PIECE(^DD(9000001,.14,0),U,2)[200:200,1:6),+Y,$SELECT($PIECE(^DD(9000001,.14,0),U,2)[200:53.5,1:2))
+4 GOTO FAC
PROVC ;cohort
+1 KILL APCLPROV,APCLPRVN,APCLPRVD
+2 SET X="PRIMARY PROVIDER"
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 XIT
+3 DO PEP^AMQQGTX0(+Y,"APCLPROV(")
+4 IF '$DATA(APCLPROV)
GOTO PROV
+5 IF $DATA(APCLPROV("*"))
WRITE !,"all not allowed with this report"
KILL APCLPROV
GOTO PROV
+6 SET Y=0
FOR
SET Y=$ORDER(APCLPROV(Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+7 SET APCLPROV(Y)=""
SET APCLPRVN(Y)=$SELECT($PIECE(^DD(9000001,.14,0),U,2)[200:$PIECE(^VA(200,Y,0),U),1:$PIECE(^DIC(16,Y,0),U))
+8 SET APCLPRVD(Y)=$$VAL^XBDIQ1($SELECT($PIECE(^DD(9000001,.14,0),U,2)[200:200,1:6),Y,$SELECT($PIECE(^DD(9000001,.14,0),U,2)[200:53.5,1:2))
End DoDot:1
FAC ;
+1 SET APCLSUH=""
+2 WRITE !!,"For use in reporting Hospital and In-Hospital information, please enter",!,"your Service Unit's Hospital. If there is no hospital in your service unit",!,"press ENTER to bypass the prompt.",!
+3 SET DIC(0)="AEMQ"
SET DIC="^AUTTLOC("
DO ^DIC
+4 IF X=""
GOTO LS
+5 IF ($DATA(DUOUT))!($DATA(DTOUT))
GOTO PROV
+6 IF Y=-1
GOTO FAC
+7 SET APCLSUH=+Y
LS ;
+1 SET APCLLSV=""
+2 SET DIR(0)="S^L:Long Version (10 items in each list);S:Short Version (5 items in each list)"
SET DIR("A")="Which Report would you like"
+3 SET DIR("B")="S"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO FAC
+5 SET APCLLSV=Y
EXCL ;exclude any diagnoses codes?
+1 KILL APCLEXCL,APCLDXT
+2 WRITE !!,"In the list of leading purpose of visits you have the option of excluding ",!,"certain ICD diagnoses from the list of top ten diagnoses.",!
+3 SET APCLEXCL=""
+4 WRITE !,"Do you wish to exclude any diagnoses codes from the list of "
+5 SET DIR(0)="Y"
SET DIR("A")="top "_$SELECT(APCLLSV="L":10,1:5)_" Purpose of Visits"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)
GOTO LS
+7 SET APCLEXCL=Y
EXCL1 ;which ones to exclude
+1 KILL APCLDXT
+2 IF 'APCLEXCL
GOTO ZIS
+3 WRITE !,"Enter the diagnoses to be excluded.",!
DX1 ;
+1 SET X="DIAGNOSIS"
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 XIT
+2 DO PEP^AMQQGTX0(+Y,"APCLDXT(")
+3 IF '$DATA(APCLDXT)
GOTO EXCL
+4 IF $DATA(APCLDXT("*"))
KILL APCLDXT
ZIS ;
ST ;;template of patients?
+1 SET APCLSEAT=""
+2 SET DIR(0)="S^A:ALL PATIENTS;S:SEARCH TEMPLATE OF PATIENTS"
SET DIR("A")="Which set of patients should be included in this report"
SET DIR("B")="A"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO EXCL
+4 IF Y="A"
GOTO DEMO
+5 SET APCLSEAT=""
+6 ;
+7 WRITE !
SET DIC("S")="I $P(^(0),U,4)=9000001"
SET DIC="^DIBT("
SET DIC("A")="Enter Patient SEARCH TEMPLATE name: "
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA,DR,DICR
+8 IF Y=-1
SET APCLSEAT=""
GOTO ST
+9 SET APCLSEAT=+Y
DEMO ;
+1 DO DEMOCHK^APCLUTL(.APCLDEMO)
+2 IF APCLDEMO=-1
GOTO EXCL
+3 SET DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen"
SET DIR("A")="Do you wish to "
SET DIR("B")="P"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO XIT
+5 IF $GET(Y)="B"
DO BROWSE
DO XIT
QUIT
+6 SET XBRP="^APCLPP2P"
SET XBRC="^APCLPP21"
SET XBNS="APCL"
SET XBRX="XIT^APCLPP2"
+7 DO ^XBDBQUE
+8 QUIT
+9 ;
XIT ;
+1 DO EN^XBVK("APCL")
+2 DO KILL^AUPNPAT
+3 DO ^XBFMK
+4 QUIT
BROWSE ;
+1 SET XBRP="VIEWR^XBLM(""^APCLPP2P"")"
+2 SET XBNS="APCL"
SET XBRC="^APCLPP21"
SET XBRX="XIT^APCLPP2"
SET XBIOP=0
DO ^XBDBQUE
+3 QUIT
+4 ;
INFORM ;tell user what is going on
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE $$CTR("************* PROVIDER PRACTICE DESCRIPTION REPORT ************",80)
+3 WRITE !!,"This report will present a profile of services provided by a selected provider."
+4 WRITE !,"You will be asked to enter a date range and to identify the provider's name.",!
+5 QUIT
SET ;EP - ENTRY POINT
+1 SET APCLC=0
FOR
SET APCLC=$ORDER(APCLPROV(APCLC))
IF APCLC'=+APCLC
QUIT
DO SETC
+2 QUIT
SETC ;
+1 SET APCL4="REPORT"
SET APCL1="COMMC"
SET APCL3="COMM"
DO SET1
+2 SET APCL4="REPORT"
SET APCL1="TRIBEC"
SET APCL3="TRIBE"
DO SET1
+3 SET APCL4="REPORT"
SET APCL1="SCC"
SET APCL3="SC"
DO SET1
+4 SET APCL4="REPORT"
SET APCL1="LOCC"
SET APCL3="LOC"
DO SET1
+5 SET APCL4="REPORT"
SET APCL1="OUTDXC"
SET APCL3="OUTDX"
DO SET1
+6 SET APCL4="REPORT"
SET APCL1="INPTDXC"
SET APCL3="INPTDX"
DO SET1
+7 SET APCL4="REPORT"
SET APCL1="PATEDC"
SET APCL3="PATED"
DO SET1
+8 SET APCL4="REPORT"
SET APCL1="SURGPROCC"
SET APCL3="SURGPROC"
DO SET1
+9 SET APCL4="REPORT"
SET APCL1="RXC"
SET APCL3="RX"
DO SET1
+10 SET APCL4="REPORT"
SET APCL1="EMC"
SET APCL3="EM"
DO SET1
+11 SET APCL4="REPORT"
SET APCL1="INPTSURGPROCC"
SET APCL3="INPTSURGPROC"
DO SET1
+12 QUIT
SET1 ;
+1 SET APCL2="^XTMP(""APCLPP2"",APCLJOB,APCLBTH,""RP"","""_APCLC_""","""_APCL4_""","""_APCL3_""",X)"
+2 SET X=""
FOR
SET X=$ORDER(@APCL2)
IF X=""
QUIT
SET %=^(X)
SET ^XTMP("APCLPP2",APCLJOB,APCLBTH,"RP",APCLC,APCL4,APCL1,9999999-%,X)=%
+3 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("A")="End of Report. Press return"
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 ;
