APCLCART.m

APCLCART ; IHS/CMI/LAB - SET UP TAX CALIF ;

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

 ;

 ;

 ;

POST ;EP

 F APCLN=60:1:70,74,80:1:90,94 S APCLTEXT="L"_APCLN D SETTAX

 Q

PCPT ;EP - called from apclcarp

 D HEADER

 Q:APCLQUIT

 S APCLV=0 F  S APCLV=$O(^XTMP("APCLCAR",APCLJ,APCLH,"NO CPT LIST",APCLV)) Q:APCLV'=+APCLV!(APCLQUIT)  D

 .I $Y>(IOSL-3) D HEADER Q:APCLQUIT

 .S P=$P(^AUPNVSIT(APCLV,0),U,5)

 .I P W !,$P(^DPT(P,0),U),?32,$$HRN^AUPNPAT(P,DUZ(2))

 .W ?39,$$VAL^XBDIQ1(9000010,APCLV,.01),?60,$E($$VAL^XBDIQ1(9000010,APCLV,.06),1,18)

 .Q

 Q

HEADER ;EP

 G:'APCLPG HEADER1

 K DIR I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCLQUIT=1 Q

HEADER1 ;

 W:$D(IOF) @IOF S APCLPG=APCLPG+1

 W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",APCLPG,!

 W !,$$CTR("***  CALIFORNIA ANNUAL UTILIZATION REPORT OF PRIMARY CARE CLINICS  ***",80),!

 W !,$$CTR("*** 2008 VERSION ***",80),!

 ;W $$CTR($P(^DIC(4,DUZ(2),0),U)),!

 I '$D(APCLLOCT) S X="ALL LOCATIONS OF ENCOUNTER SELECTED" W $$CTR(X,80),!

 I $D(APCLLOCT) D

 .S X="Locations Selected:"

 .S Y=0 F  S Y=$O(APCLLOCT(Y)) Q:Y'=+Y  S X=X_"  "_$P(^DIC(4,Y,0),U)

 .W X,!

 S X="Reporting Period: "_$$FMTE^XLFDT(APCLBD)_" to "_$$FMTE^XLFDT(APCLED) W $$CTR(X,80),!

 S X="List of Visits with NO CPT code" W $$CTR(X,80),!

 W !,"Patient Name",?32,"HRN",?39,"Visit Date",?60,"Location"

 W !,$TR($J("",80)," ","-")

 Q

CTR(X,Y) ;EP - Center X in a field Y wide.

 Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X

 ;----------

SETTAX ;

 S ATXFLG=1

 S APCLT=$T(@APCLTEXT),APCLTN=$P(APCLT,";;",2),APCLTN="APCL CAR "_APCLTEXT

 ;W !,"Creating Primary Care Prov disc taxonomy...",APCLTN

 S APCLDA=0 S APCLDA=$O(^ATXAX("B",APCLTN,APCLDA)) I APCLDA K ^ATXAX(APCLDA,21) S APCLTX=APCLDA G SETTAX1

 S X=APCLTN,DIC="^ATXAX(",DIC(0)="L",DIADD=1,DLAYGO=9002226 D ^DIC K DIC,DA,DIADD,DLAYGO,I

 I Y=-1 W !!,"ERROR IN CREATING APCL PRIMARY PROVIDER DISC" Q

 S APCLTX=+Y

SETTAX1 ;

 S $P(^ATXAX(APCLTX,0),U,2)=APCLTN,$P(^(0),U,5)=DUZ,$P(^(0),U,8)=0,$P(^(0),U,9)=DT,$P(^(0),U,12)=210,$P(^(0),U,13)=0,$P(^(0),U,15)=7,^ATXAX(APCLTX,21,0)="^9002226.02101A^0^0"

 D ^XBFMK K DIADD,DLAYGO S APCLC=0 F APCLX=1:1 S X=$P($T(@APCLTEXT+APCLX),";;",2) Q:X=""  S Y=0 F  S Y=$O(^DIC(7,"D",X,Y)) Q:Y'=+Y  K DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0 D

 .S APCLC=APCLC+1 S ^ATXAX(APCLTX,21,APCLC,0)=+Y,$P(^ATXAX(APCLTX,21,0),U,3)=APCLC,$P(^(0),U,4)=APCLC,^ATXAX(APCLTX,21,"AA",+Y,APCLC)=""

 .Q

 S DA=APCLTX,DIK="^ATXAX(" D IX1^DIK

 K ATXFLG

 Q

 ;

L94 ;;OTHER 2

 ;;C3

 ;;C4

 ;;C5

 ;;C6

 ;;C7

 ;;C2

 ;;C1

 ;;B8

 ;;A8

 ;;A6

 ;;A3

 ;;A2

 ;;95

 ;;94

 ;;91

 ;;89

 ;;87

 ;;84

 ;;67

 ;;66

 ;;65

 ;;59

 ;;53

 ;;47

 ;;43

 ;;42

 ;;39

 ;;38

 ;;36

 ;;31

 ;;30

 ;;27

 ;;23

 ;;22

 ;;20

 ;;19

 ;;14

 ;;09

 ;;06

 ;;02

 ;;

L90 ;;

 ;;

L89 ;;

 ;;

L88 ;;

 ;;48

 ;;

L87 ;;

 ;;99

 ;;97

 ;;93

 ;;37

 ;;35

 ;;34

 ;;29

 ;;26

 ;;07

 ;;04

 ;;

L86 ;;

 ;;03

 ;;

L85 ;;

 ;;05

 ;;

L84 ;;

 ;;32

 ;;01

 ;;13

 ;;

L83 ;;

 ;;A7

 ;;96

 ;;

L82 ;;

 ;;

L81 ;;

 ;;60

 ;;54

 ;;

L80 ;;

 ;;46

 ;;

L74 ;;

 ;;

L70 ;;

 ;;A5

 ;;90

 ;;83

 ;;82

 ;;76

 ;;73

 ;;69

 ;;28

 ;;24

 ;;10

 ;;08

 ;;

L69 ;;

 ;;63

 ;;62

 ;;

L68 ;;

 ;;92

 ;;50

 ;;12

 ;;

L67 ;;

 ;;81

 ;;49

 ;;

L66 ;;

 ;;

L65 ;;

 ;;52

 ;;

L64 ;;

 ;;

L63 ;;

 ;;17

 ;;

L62 ;;

 ;;21

 ;;16

 ;;

L61 ;;

 ;;11

 ;;

L60 ;;

 ;;B6

 ;;B5

 ;;B4

 ;;B3

 ;;B2

 ;;B1

 ;;A9

 ;;A4

 ;;A1

 ;;86

 ;;85

 ;;80

 ;;79

 ;;78

 ;;77

 ;;75

 ;;74

 ;;72

 ;;71

 ;;70

 ;;68

 ;;64

 ;;45

 ;;44

 ;;41

 ;;33

 ;;25

 ;;18

 ;;00

 ;;

APCLCART  ; IHS/CMI/LAB - SET UP TAX CALIF ;

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

 +2       ;

 +3       ;

 +4       ;

POST      ;EP

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

               SET APCLTEXT="L"_APCLN

               DO SETTAX

 +2        QUIT 

PCPT      ;EP - called from apclcarp

 +1        DO HEADER

 +2        IF APCLQUIT

               QUIT 

 +3        SET APCLV=0

           FOR 

               SET APCLV=$ORDER(^XTMP("APCLCAR",APCLJ,APCLH,"NO CPT LIST",APCLV))

               IF APCLV'=+APCLV!(APCLQUIT)

                   QUIT 

               Begin DoDot:1

 +4                IF $Y>(IOSL-3)

                       DO HEADER

                       IF APCLQUIT

                           QUIT 

 +5                SET P=$PIECE(^AUPNVSIT(APCLV,0),U,5)

 +6                IF P

                       WRITE !,$PIECE(^DPT(P,0),U),?32,$$HRN^AUPNPAT(P,DUZ(2))

 +7                WRITE ?39,$$VAL^XBDIQ1(9000010,APCLV,.01),?60,$EXTRACT($$VAL^XBDIQ1(9000010,APCLV,.06),1,18)

 +8                QUIT 

               End DoDot:1

 +9        QUIT 

HEADER    ;EP

 +1        IF 'APCLPG

               GOTO HEADER1

 +2        KILL DIR

           IF $EXTRACT(IOST)="C"

               IF IO=IO(0)

                   WRITE !

                   SET DIR(0)="EO"

                   DO ^DIR

                   KILL DIR

                   IF Y=0!(Y="^")!($DATA(DTOUT))

                       SET APCLQUIT=1

                       QUIT 

HEADER1   ;

 +1        IF $DATA(IOF)

               WRITE @IOF

           SET APCLPG=APCLPG+1

 +2        WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",APCLPG,!

 +3        WRITE !,$$CTR("***  CALIFORNIA ANNUAL UTILIZATION REPORT OF PRIMARY CARE CLINICS  ***",80),!

 +4        WRITE !,$$CTR("*** 2008 VERSION ***",80),!

 +5       ;W $$CTR($P(^DIC(4,DUZ(2),0),U)),!

 +6        IF '$DATA(APCLLOCT)

               SET X="ALL LOCATIONS OF ENCOUNTER SELECTED"

               WRITE $$CTR(X,80),!

 +7        IF $DATA(APCLLOCT)

               Begin DoDot:1

 +8                SET X="Locations Selected:"

 +9                SET Y=0

                   FOR 

                       SET Y=$ORDER(APCLLOCT(Y))

                       IF Y'=+Y

                           QUIT 

                       SET X=X_"  "_$PIECE(^DIC(4,Y,0),U)

 +10               WRITE X,!

               End DoDot:1

 +11       SET X="Reporting Period: "_$$FMTE^XLFDT(APCLBD)_" to "_$$FMTE^XLFDT(APCLED)

           WRITE $$CTR(X,80),!

 +12       SET X="List of Visits with NO CPT code"

           WRITE $$CTR(X,80),!

 +13       WRITE !,"Patient Name",?32,"HRN",?39,"Visit Date",?60,"Location"

 +14       WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")

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

SETTAX    ;

 +1        SET ATXFLG=1

 +2        SET APCLT=$TEXT(@APCLTEXT)

           SET APCLTN=$PIECE(APCLT,";;",2)

           SET APCLTN="APCL CAR "_APCLTEXT

 +3       ;W !,"Creating Primary Care Prov disc taxonomy...",APCLTN

 +4        SET APCLDA=0

           SET APCLDA=$ORDER(^ATXAX("B",APCLTN,APCLDA))

           IF APCLDA

               KILL ^ATXAX(APCLDA,21)

               SET APCLTX=APCLDA

               GOTO SETTAX1

 +5        SET X=APCLTN

           SET DIC="^ATXAX("

           SET DIC(0)="L"

           SET DIADD=1

           SET DLAYGO=9002226

           DO ^DIC

           KILL DIC,DA,DIADD,DLAYGO,I

 +6        IF Y=-1

               WRITE !!,"ERROR IN CREATING APCL PRIMARY PROVIDER DISC"

               QUIT 

 +7        SET APCLTX=+Y

SETTAX1   ;

 +1        SET $PIECE(^ATXAX(APCLTX,0),U,2)=APCLTN

           SET $PIECE(^(0),U,5)=DUZ

           SET $PIECE(^(0),U,8)=0

           SET $PIECE(^(0),U,9)=DT

           SET $PIECE(^(0),U,12)=210

           SET $PIECE(^(0),U,13)=0

           SET $PIECE(^(0),U,15)=7

           SET ^ATXAX(APCLTX,21,0)="^9002226.02101A^0^0"

 +2        DO ^XBFMK

           KILL DIADD,DLAYGO

           SET APCLC=0

           FOR APCLX=1:1

               SET X=$PIECE($TEXT(@APCLTEXT+APCLX),";;",2)

               IF X=""

                   QUIT 

               SET Y=0

               FOR 

                   SET Y=$ORDER(^DIC(7,"D",X,Y))

                   IF Y'=+Y

                       QUIT 

                   KILL DIC,DA,DR,DIADD,DLAYGO,DQ,DI,D1,D0

                   Begin DoDot:1

 +3                    SET APCLC=APCLC+1

                       SET ^ATXAX(APCLTX,21,APCLC,0)=+Y

                       SET $PIECE(^ATXAX(APCLTX,21,0),U,3)=APCLC

                       SET $PIECE(^(0),U,4)=APCLC

                       SET ^ATXAX(APCLTX,21,"AA",+Y,APCLC)=""

 +4                    QUIT 

                   End DoDot:1

 +5        SET DA=APCLTX

           SET DIK="^ATXAX("

           DO IX1^DIK

 +6        KILL ATXFLG

 +7        QUIT 

 +8       ;

L94       ;;OTHER 2

 +1       ;;C3

 +2       ;;C4

 +3       ;;C5

 +4       ;;C6

 +5       ;;C7

 +6       ;;C2

 +7       ;;C1

 +8       ;;B8

 +9       ;;A8

 +10      ;;A6

 +11      ;;A3

 +12      ;;A2

 +13      ;;95

 +14      ;;94

 +15      ;;91

 +16      ;;89

 +17      ;;87

 +18      ;;84

 +19      ;;67

 +20      ;;66

 +21      ;;65

 +22      ;;59

 +23      ;;53

 +24      ;;47

 +25      ;;43

 +26      ;;42

 +27      ;;39

 +28      ;;38

 +29      ;;36

 +30      ;;31

 +31      ;;30

 +32      ;;27

 +33      ;;23

 +34      ;;22

 +35      ;;20

 +36      ;;19

 +37      ;;14

 +38      ;;09

 +39      ;;06

 +40      ;;02

 +41      ;;

L90       ;;

 +1       ;;

L89       ;;

 +1       ;;

L88       ;;

 +1       ;;48

 +2       ;;

L87       ;;

 +1       ;;99

 +2       ;;97

 +3       ;;93

 +4       ;;37

 +5       ;;35

 +6       ;;34

 +7       ;;29

 +8       ;;26

 +9       ;;07

 +10      ;;04

 +11      ;;

L86       ;;

 +1       ;;03

 +2       ;;

L85       ;;

 +1       ;;05

 +2       ;;

L84       ;;

 +1       ;;32

 +2       ;;01

 +3       ;;13

 +4       ;;

L83       ;;

 +1       ;;A7

 +2       ;;96

 +3       ;;

L82       ;;

 +1       ;;

L81       ;;

 +1       ;;60

 +2       ;;54

 +3       ;;

L80       ;;

 +1       ;;46

 +2       ;;

L74       ;;

 +1       ;;

L70       ;;

 +1       ;;A5

 +2       ;;90

 +3       ;;83

 +4       ;;82

 +5       ;;76

 +6       ;;73

 +7       ;;69

 +8       ;;28

 +9       ;;24

 +10      ;;10

 +11      ;;08

 +12      ;;

L69       ;;

 +1       ;;63

 +2       ;;62

 +3       ;;

L68       ;;

 +1       ;;92

 +2       ;;50

 +3       ;;12

 +4       ;;

L67       ;;

 +1       ;;81

 +2       ;;49

 +3       ;;

L66       ;;

 +1       ;;

L65       ;;

 +1       ;;52

 +2       ;;

L64       ;;

 +1       ;;

L63       ;;

 +1       ;;17

 +2       ;;

L62       ;;

 +1       ;;21

 +2       ;;16

 +3       ;;

L61       ;;

 +1       ;;11

 +2       ;;

L60       ;;

 +1       ;;B6

 +2       ;;B5

 +3       ;;B4

 +4       ;;B3

 +5       ;;B2

 +6       ;;B1

 +7       ;;A9

 +8       ;;A4

 +9       ;;A1

 +10      ;;86

 +11      ;;85

 +12      ;;80

 +13      ;;79

 +14      ;;78

 +15      ;;77

 +16      ;;75

 +17      ;;74

 +18      ;;72

 +19      ;;71

 +20      ;;70

 +21      ;;68

 +22      ;;64

 +23      ;;45

 +24      ;;44

 +25      ;;41

 +26      ;;33

 +27      ;;25

 +28      ;;18

 +29      ;;00

 +30      ;;