APCLPP2.m

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       ;