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