APCLCAR2 ; IHS/CMI/LAB - California report ;
;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009
;
;
SECT5 ;EP
I $$CLINIC^APCLV(APCLVSIT,"C")=56 S G=32 D SET Q
I $D(^AUPNVDEN("AD",APCLVSIT)) S G=32 D SET Q
D GETPCPT
I X="" S APCLNCPT=APCLNCPT+1 I APCLCPTR S ^XTMP("APCLCAR",APCLJ,APCLH,"NO CPT LIST",APCLVSIT)=""
I X]"" D CPTCHK
S APCLC=0 F S APCLC=$O(AUPNCPT(APCLC)) Q:APCLC'=+APCLC S C=$P(AUPNCPT(APCLC),U) D SPEC,SPEC2
Q
SET ;
S ^XTMP("APCLCAR",APCLJ,APCLH,"CPT",G)=$G(^XTMP("APCLCAR",APCLJ,APCLH,"CPT",G))+1,APCLTOTR=APCLTOTR+1
Q
SETSPEC ;
S ^XTMP("APCLCAR",APCLJ,APCLH,"CPT",G)=$G(^XTMP("APCLCAR",APCLJ,APCLH,"CPT",G))+1,APCLSPE1=APCLSPE1+1
Q
SPEC2 ;
60 ;
I C=90389 S G=60 D SETSPEC2 Q
I C=90696 S G=60 D SETSPEC2 Q
I C=90698 S G=60 D SETSPEC2 Q
I C>90699,C<90704 S G=60 D SETSPEC2 Q
I C>90713,C<90716 S G=60 D SETSPEC2 Q
I C>90717,C<90724 S G=60 D SETSPEC2 Q
61 I C>90644,C<90649 S G=61 D SETSPEC2 Q
I C=90371 S G=61 D SETSPEC2 Q
62 I C>90631,C<90635 S G=62 D SETSPEC2 Q
I C=90636 S G=62 D SETSPEC2 Q
63 ;
I C=90740 S G=63 D SETSPEC2 Q
I C=90743 S G=63 D SETSPEC2 Q
I C=90744 S G=63 D SETSPEC2 Q
I C=90746 S G=63 D SETSPEC2 Q
I C=90747 S G=63 D SETSPEC2 Q
64 I C=90748 S G=64 D SETSPEC2 Q
65 I C>90654,C<90659 S G=65 D SETSPEC2 Q
I C=90660 S G=65 D SETSPEC2 Q
I C=90661 S G=65 D SETSPEC2 Q
I C=90662 S G=65 D SETSPEC2 Q
I C=90663 S G=65 D SETSPEC2 Q
I C=90664 S G=65 D SETSPEC2 Q
I C=90665 S G=65 D SETSPEC2 Q
I C=90666 S G=65 D SETSPEC2 Q
I C=90667 S G=65 D SETSPEC2 Q
I C=90668 S G=65 D SETSPEC2 Q
66 I C>90703,C<90709 S G=66 D SETSPEC2 Q
I C=90708 S G=66 D SETSPEC2 Q
I C=90710 S G=66 D SETSPEC2 Q
67 I C=90669 S G=67 D SETSPEC2 Q
I C=90670 S G=67 D SETSPEC2 Q
I C=90732 S G=67 D SETSPEC2 Q
68 I C=90712!(C=90713) S G=68 D SETSPEC2 Q
69 I C=90716 S G=69 D SETSPEC2 Q
I C=90396 S G=69 D SETSPEC2 Q
Q
SPEC ;
50 ;
I C>77050,C<77060 S G=50 D SETSPEC Q
51 I C>86700,C<86704 S G=51 D SETSPEC Q
I C=86689 S G=51 D SETSPEC Q
I C>87389,C<87392 S G=51 D SETSPEC Q
52 I C>88140,C<88156 S G=52 D SETSPEC Q
I C>88163,C<88168 S G=52 D SETSPEC Q
I C=88174 S G=52 D SETSPEC Q
I C=88175 S G=52 D SETSPEC Q
53 I C>11974,C<11978 S G=53 D SETSPEC Q
I C=55250 S G=53 D SETSPEC Q
I C=55300 S G=53 D SETSPEC Q
I C=55400 S G=53 D SETSPEC Q
I C=55450 S G=53 D SETSPEC Q
I C=55170 S G=53 D SETSPEC Q
I C=58300 S G=53 D SETSPEC Q
I C=58301 S G=53 D SETSPEC Q
I C=58600 S G=53 D SETSPEC Q
I C=58605 S G=53 D SETSPEC Q
I C=58611 S G=53 D SETSPEC Q
I C>58669,C<58672 S G=53 D SETSPEC Q
Q
SETSPEC2 ;
S ^XTMP("APCLCAR",APCLJ,APCLH,"CPT",G)=$G(^XTMP("APCLCAR",APCLJ,APCLH,"CPT",G))+1,APCLSPE2=APCLSPE2+1
Q
GETPCPT ;get primary cpt. e&m then most expensive
K AUPNCPT,APCLPCPT,X,Y,Z,C
S E=$$CPT^AUPNCPT(APCLVSIT)
S (APCLC,Y)=0 F S Y=$O(AUPNCPT(Y)) Q:Y'=+Y S APCLC=Y
S Y=0 F S Y=$O(^AUPNVIMM("AD",APCLVSIT,Y)) Q:Y'=+Y D
.S I=$P($G(^AUPNVIMM(Y,0)),U) Q:'I Q:'$D(^AUTTIMM(I,0))
.S APCLCPT=$P(^AUTTIMM(I,0),U,11)
.Q:'APCLCPT
.S APCLC=APCLC+1,AUPNCPT(APCLC)=$P($$CPT^ICPTCOD(APCLCPT),U,2)_U_U_APCLCPT ;cmi/anch/maw 9/12/2007 csv
S Y=0 F S Y=$O(^AUPNVLAB("AD",APCLVSIT,Y)) Q:Y'=+Y D
.Q:$P($G(^AUPNVLAB(Y,14)),U,2)=""
.S Z=$P(^AUPNVLAB(Y,14),U,2)
.F I=1:1 S C=$P(Z,";",I) Q:C="" S APCLCPT=$P(C,"|") I APCLCPT,$D(^ICPT(APCLCPT,0)) S APCLC=APCLC+1,AUPNCPT(APCLC)=$P($$CPT^ICPTCOD(APCLCPT,0),U)_U_U_APCLCPT ;cmi/anch/maw 9/12/2007 csv
;unduplicate in AUPNCPT
K Z S Y="",X=0 F S X=$O(AUPNCPT(X)) Q:X'=+X S Y=$P(AUPNCPT(X),U) K:$D(Z(Y)) AUPNCPT(X) S Z(Y)=""
K Z,X,Y
;loop through and find E&M
S (X,M)=""
S C=0 F S C=$O(AUPNCPT(C)) Q:C'=+C!(X]"") D
.S APCLC=$P(AUPNCPT(C),U),APCLC1=$P(AUPNCPT(C),U,3)
.I APCLC>99200,APCLC<99500 S X=APCLC1 Q
.S F=$$FEEAMT(APCLC1,APCLFEE)
.I F>$P(M,U)!(M="") S M=F_U_APCLC1
.Q
I X="" S X=$P(M,U,2)
Q
CPTCHK ;
Q:'$D(^ICPT(X,0))
S C=$P($$CPT^ICPTCOD(X),U,2) ;cmi/anch/maw 9/12/2007 csv
1 I C>99200,C<99206 S G=1 D SET Q
2 I C>99210,C<99216 S G=2 D SET Q
3 I C>99216,C<99224 S G=3 D SET Q
I C>99230,C<99240 S G=3 D SET Q
I C=99477 S G=3 D SET Q
4 I C>99240,C<99246 S G=4 D SET Q
I C>99440,C<99445 S G=4 D SET Q
5 I C=99291 S G=5 D SET Q
I C=99292 S G=5 D SET Q
I C>99353,C<99361 S G=5 D SET Q
I C=99450 S G=5 D SET Q
I C=99455 S G=5 D SET Q
I C=99456 S G=5 D SET Q
I C=99499 S G=5 D SET Q
6 I C>99303,C<99319 S G=6 D SET Q
7 I C=99363 S G=7 D SET Q
I C=99364 S G=7 D SET Q
I C=99366 S G=7 D SET Q
I C=99367 S G=7 D SET Q
I C=99368 S G=7 D SET Q
8 I C>99380,C<99385 S G=8 D SET Q
I C>99390,C<99395 S G=8 D SET Q
I C=99461 S G=8 D SET Q
9 I C>99384,C<99388 S G=9 D SET Q
I C>99394,C<99398 S G=9 D SET Q
10 ;counseling
I C>99400,C<99405 S G=10 D SET Q
I C>99405,C<99410 S G=10 D SET Q
I C>99410,C<99413 S G=10 D SET Q
I C>99419,C<99430 S G=10 D SET Q
I C>99604,C<99608 S G=10 D SET Q
11 ;anesthesia
F N=1 F Z=1:1:5 I +$E(C,Z)'=+$E(C,Z) S N=0
I N,+C>99,+C<2000 S G=11 D SET Q
I C=99100 S G=11 D SET Q
I C=99116 S G=11 D SET Q
I C=99135 S G=11 D SET Q
I C=99140 S G=11 D SET Q
I C>99142,C<99151 D SET Q
12 I C>10020,C<19500 S G=12 D SET Q
13 I C>19999,C<30000 S G=13 D SET Q
14 I C>29999,C<33000 S G=14 D SET Q
15 I C>33009,C<37800 S G=15 D SET Q
16 I C>38099,C<39000 S G=16 D SET Q
17 I C>38999,C<39600 S G=17 D SET Q
18 I C>40489,C<50000 S G=18 D SET Q
19 I C>50009,C<53900 S G=19 D SET Q
20 I C>53999,C<55921 S G=20 D SET Q
21 I C=55970 S G=21 D SET Q
I C=55980 S G=21 D SET Q
22 I C>56404,C<59000 S G=22 D SET Q
23 I C>58999,C<59900 S G=23 D SET Q
24 I C>59999,C<60700 S G=24 D SET Q
25 I C>60999,C<65000 S G=25 D SET Q
26 I C>65090,C<68900 S G=26 D SET Q
27 I C>68999,C<69980 S G=27 D SET Q
28 I C>70009,C<80000 S G=28 D SET Q
29 I C>80046,C<89357 S G=29 D SET Q
I C=89398 S G=29 D SET Q
30 I C>90280,C<99092 S G=30 D SET Q
I C>99169,C<99200 S G=30 D SET Q
31 ;
32 ;
33 I $E(C,5)="T",+C>15 S G=33 D SET Q
44 S G=44 D SET Q
Q
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
;
FEEAMT(C,T) ;
I '$G(T) Q ""
I '$G(C) Q ""
;return fee amt for cpt ien C
NEW X,A
S X=0,A=""
F S X=$O(^ABMDFEE(T,X)) Q:X'=+X!(A]"") I $D(^ABMDFEE(T,X,"B",C)) S Y=$O(^ABMDFEE(T,X,"B",C,0)) S A=$P(^ABMDFEE(T,X,Y,0),U,2)
Q A
;
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")
;----------
O ;one location
S DIC="^AUTTLOC(",DIC(0)="AEMQ",DIC("A")="Which LOCATION: " D ^DIC K DIC
I Y=-1 S APCLQ="" Q
S APCLLOCT("ONE")=+Y
Q
S ;all communities within APCLSU su
S DIC="^AUTTSU(",DIC("B")=$$VAL^XBDIQ1(9999999.06,DUZ(2),.05),DIC(0)="AEMQ",DIC("A")="Which SERVICE UNIT: " D ^DIC K DIC
I Y=-1 S APCLQ="" Q
S APCLLOCT("SU")=+Y
Q
;
APCLCAR2 ; IHS/CMI/LAB - California report ;
+1 ;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009
+2 ;
+3 ;
SECT5 ;EP
+1 IF $$CLINIC^APCLV(APCLVSIT,"C")=56
SET G=32
DO SET
QUIT
+2 IF $DATA(^AUPNVDEN("AD",APCLVSIT))
SET G=32
DO SET
QUIT
+3 DO GETPCPT
+4 IF X=""
SET APCLNCPT=APCLNCPT+1
IF APCLCPTR
SET ^XTMP("APCLCAR",APCLJ,APCLH,"NO CPT LIST",APCLVSIT)=""
+5 IF X]""
DO CPTCHK
+6 SET APCLC=0
FOR
SET APCLC=$ORDER(AUPNCPT(APCLC))
IF APCLC'=+APCLC
QUIT
SET C=$PIECE(AUPNCPT(APCLC),U)
DO SPEC
DO SPEC2
+7 QUIT
SET ;
+1 SET ^XTMP("APCLCAR",APCLJ,APCLH,"CPT",G)=$GET(^XTMP("APCLCAR",APCLJ,APCLH,"CPT",G))+1
SET APCLTOTR=APCLTOTR+1
+2 QUIT
SETSPEC ;
+1 SET ^XTMP("APCLCAR",APCLJ,APCLH,"CPT",G)=$GET(^XTMP("APCLCAR",APCLJ,APCLH,"CPT",G))+1
SET APCLSPE1=APCLSPE1+1
+2 QUIT
SPEC2 ;
60 ;
+1 IF C=90389
SET G=60
DO SETSPEC2
QUIT
+2 IF C=90696
SET G=60
DO SETSPEC2
QUIT
+3 IF C=90698
SET G=60
DO SETSPEC2
QUIT
+4 IF C>90699
IF C<90704
SET G=60
DO SETSPEC2
QUIT
+5 IF C>90713
IF C<90716
SET G=60
DO SETSPEC2
QUIT
+6 IF C>90717
IF C<90724
SET G=60
DO SETSPEC2
QUIT
61 IF C>90644
IF C<90649
SET G=61
DO SETSPEC2
QUIT
+1 IF C=90371
SET G=61
DO SETSPEC2
QUIT
62 IF C>90631
IF C<90635
SET G=62
DO SETSPEC2
QUIT
+1 IF C=90636
SET G=62
DO SETSPEC2
QUIT
63 ;
+1 IF C=90740
SET G=63
DO SETSPEC2
QUIT
+2 IF C=90743
SET G=63
DO SETSPEC2
QUIT
+3 IF C=90744
SET G=63
DO SETSPEC2
QUIT
+4 IF C=90746
SET G=63
DO SETSPEC2
QUIT
+5 IF C=90747
SET G=63
DO SETSPEC2
QUIT
64 IF C=90748
SET G=64
DO SETSPEC2
QUIT
65 IF C>90654
IF C<90659
SET G=65
DO SETSPEC2
QUIT
+1 IF C=90660
SET G=65
DO SETSPEC2
QUIT
+2 IF C=90661
SET G=65
DO SETSPEC2
QUIT
+3 IF C=90662
SET G=65
DO SETSPEC2
QUIT
+4 IF C=90663
SET G=65
DO SETSPEC2
QUIT
+5 IF C=90664
SET G=65
DO SETSPEC2
QUIT
+6 IF C=90665
SET G=65
DO SETSPEC2
QUIT
+7 IF C=90666
SET G=65
DO SETSPEC2
QUIT
+8 IF C=90667
SET G=65
DO SETSPEC2
QUIT
+9 IF C=90668
SET G=65
DO SETSPEC2
QUIT
66 IF C>90703
IF C<90709
SET G=66
DO SETSPEC2
QUIT
+1 IF C=90708
SET G=66
DO SETSPEC2
QUIT
+2 IF C=90710
SET G=66
DO SETSPEC2
QUIT
67 IF C=90669
SET G=67
DO SETSPEC2
QUIT
+1 IF C=90670
SET G=67
DO SETSPEC2
QUIT
+2 IF C=90732
SET G=67
DO SETSPEC2
QUIT
68 IF C=90712!(C=90713)
SET G=68
DO SETSPEC2
QUIT
69 IF C=90716
SET G=69
DO SETSPEC2
QUIT
+1 IF C=90396
SET G=69
DO SETSPEC2
QUIT
+2 QUIT
SPEC ;
50 ;
+1 IF C>77050
IF C<77060
SET G=50
DO SETSPEC
QUIT
51 IF C>86700
IF C<86704
SET G=51
DO SETSPEC
QUIT
+1 IF C=86689
SET G=51
DO SETSPEC
QUIT
+2 IF C>87389
IF C<87392
SET G=51
DO SETSPEC
QUIT
52 IF C>88140
IF C<88156
SET G=52
DO SETSPEC
QUIT
+1 IF C>88163
IF C<88168
SET G=52
DO SETSPEC
QUIT
+2 IF C=88174
SET G=52
DO SETSPEC
QUIT
+3 IF C=88175
SET G=52
DO SETSPEC
QUIT
53 IF C>11974
IF C<11978
SET G=53
DO SETSPEC
QUIT
+1 IF C=55250
SET G=53
DO SETSPEC
QUIT
+2 IF C=55300
SET G=53
DO SETSPEC
QUIT
+3 IF C=55400
SET G=53
DO SETSPEC
QUIT
+4 IF C=55450
SET G=53
DO SETSPEC
QUIT
+5 IF C=55170
SET G=53
DO SETSPEC
QUIT
+6 IF C=58300
SET G=53
DO SETSPEC
QUIT
+7 IF C=58301
SET G=53
DO SETSPEC
QUIT
+8 IF C=58600
SET G=53
DO SETSPEC
QUIT
+9 IF C=58605
SET G=53
DO SETSPEC
QUIT
+10 IF C=58611
SET G=53
DO SETSPEC
QUIT
+11 IF C>58669
IF C<58672
SET G=53
DO SETSPEC
QUIT
+12 QUIT
SETSPEC2 ;
+1 SET ^XTMP("APCLCAR",APCLJ,APCLH,"CPT",G)=$GET(^XTMP("APCLCAR",APCLJ,APCLH,"CPT",G))+1
SET APCLSPE2=APCLSPE2+1
+2 QUIT
GETPCPT ;get primary cpt. e&m then most expensive
+1 KILL AUPNCPT,APCLPCPT,X,Y,Z,C
+2 SET E=$$CPT^AUPNCPT(APCLVSIT)
+3 SET (APCLC,Y)=0
FOR
SET Y=$ORDER(AUPNCPT(Y))
IF Y'=+Y
QUIT
SET APCLC=Y
+4 SET Y=0
FOR
SET Y=$ORDER(^AUPNVIMM("AD",APCLVSIT,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+5 SET I=$PIECE($GET(^AUPNVIMM(Y,0)),U)
IF 'I
QUIT
IF '$DATA(^AUTTIMM(I,0))
QUIT
+6 SET APCLCPT=$PIECE(^AUTTIMM(I,0),U,11)
+7 IF 'APCLCPT
QUIT
+8 ;cmi/anch/maw 9/12/2007 csv
SET APCLC=APCLC+1
SET AUPNCPT(APCLC)=$PIECE($$CPT^ICPTCOD(APCLCPT),U,2)_U_U_APCLCPT
End DoDot:1
+9 SET Y=0
FOR
SET Y=$ORDER(^AUPNVLAB("AD",APCLVSIT,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+10 IF $PIECE($GET(^AUPNVLAB(Y,14)),U,2)=""
QUIT
+11 SET Z=$PIECE(^AUPNVLAB(Y,14),U,2)
+12 ;cmi/anch/maw 9/12/2007 csv
FOR I=1:1
SET C=$PIECE(Z,";",I)
IF C=""
QUIT
SET APCLCPT=$PIECE(C,"|")
IF APCLCPT
IF $DATA(^ICPT(APCLCPT,0))
SET APCLC=APCLC+1
SET AUPNCPT(APCLC)=$PIECE($$CPT^ICPTCOD(APCLCPT,0),U)_U_U_APCLCPT
End DoDot:1
+13 ;unduplicate in AUPNCPT
+14 KILL Z
SET Y=""
SET X=0
FOR
SET X=$ORDER(AUPNCPT(X))
IF X'=+X
QUIT
SET Y=$PIECE(AUPNCPT(X),U)
IF $DATA(Z(Y))
KILL AUPNCPT(X)
SET Z(Y)=""
+15 KILL Z,X,Y
+16 ;loop through and find E&M
+17 SET (X,M)=""
+18 SET C=0
FOR
SET C=$ORDER(AUPNCPT(C))
IF C'=+C!(X]"")
QUIT
Begin DoDot:1
+19 SET APCLC=$PIECE(AUPNCPT(C),U)
SET APCLC1=$PIECE(AUPNCPT(C),U,3)
+20 IF APCLC>99200
IF APCLC<99500
SET X=APCLC1
QUIT
+21 SET F=$$FEEAMT(APCLC1,APCLFEE)
+22 IF F>$PIECE(M,U)!(M="")
SET M=F_U_APCLC1
+23 QUIT
End DoDot:1
+24 IF X=""
SET X=$PIECE(M,U,2)
+25 QUIT
CPTCHK ;
+1 IF '$DATA(^ICPT(X,0))
QUIT
+2 ;cmi/anch/maw 9/12/2007 csv
SET C=$PIECE($$CPT^ICPTCOD(X),U,2)
1 IF C>99200
IF C<99206
SET G=1
DO SET
QUIT
2 IF C>99210
IF C<99216
SET G=2
DO SET
QUIT
3 IF C>99216
IF C<99224
SET G=3
DO SET
QUIT
+1 IF C>99230
IF C<99240
SET G=3
DO SET
QUIT
+2 IF C=99477
SET G=3
DO SET
QUIT
4 IF C>99240
IF C<99246
SET G=4
DO SET
QUIT
+1 IF C>99440
IF C<99445
SET G=4
DO SET
QUIT
5 IF C=99291
SET G=5
DO SET
QUIT
+1 IF C=99292
SET G=5
DO SET
QUIT
+2 IF C>99353
IF C<99361
SET G=5
DO SET
QUIT
+3 IF C=99450
SET G=5
DO SET
QUIT
+4 IF C=99455
SET G=5
DO SET
QUIT
+5 IF C=99456
SET G=5
DO SET
QUIT
+6 IF C=99499
SET G=5
DO SET
QUIT
6 IF C>99303
IF C<99319
SET G=6
DO SET
QUIT
7 IF C=99363
SET G=7
DO SET
QUIT
+1 IF C=99364
SET G=7
DO SET
QUIT
+2 IF C=99366
SET G=7
DO SET
QUIT
+3 IF C=99367
SET G=7
DO SET
QUIT
+4 IF C=99368
SET G=7
DO SET
QUIT
8 IF C>99380
IF C<99385
SET G=8
DO SET
QUIT
+1 IF C>99390
IF C<99395
SET G=8
DO SET
QUIT
+2 IF C=99461
SET G=8
DO SET
QUIT
9 IF C>99384
IF C<99388
SET G=9
DO SET
QUIT
+1 IF C>99394
IF C<99398
SET G=9
DO SET
QUIT
10 ;counseling
+1 IF C>99400
IF C<99405
SET G=10
DO SET
QUIT
+2 IF C>99405
IF C<99410
SET G=10
DO SET
QUIT
+3 IF C>99410
IF C<99413
SET G=10
DO SET
QUIT
+4 IF C>99419
IF C<99430
SET G=10
DO SET
QUIT
+5 IF C>99604
IF C<99608
SET G=10
DO SET
QUIT
11 ;anesthesia
+1 FOR N=1
FOR Z=1:1:5
IF +$EXTRACT(C,Z)'=+$EXTRACT(C,Z)
SET N=0
+2 IF N
IF +C>99
IF +C<2000
SET G=11
DO SET
QUIT
+3 IF C=99100
SET G=11
DO SET
QUIT
+4 IF C=99116
SET G=11
DO SET
QUIT
+5 IF C=99135
SET G=11
DO SET
QUIT
+6 IF C=99140
SET G=11
DO SET
QUIT
+7 IF C>99142
IF C<99151
DO SET
QUIT
12 IF C>10020
IF C<19500
SET G=12
DO SET
QUIT
13 IF C>19999
IF C<30000
SET G=13
DO SET
QUIT
14 IF C>29999
IF C<33000
SET G=14
DO SET
QUIT
15 IF C>33009
IF C<37800
SET G=15
DO SET
QUIT
16 IF C>38099
IF C<39000
SET G=16
DO SET
QUIT
17 IF C>38999
IF C<39600
SET G=17
DO SET
QUIT
18 IF C>40489
IF C<50000
SET G=18
DO SET
QUIT
19 IF C>50009
IF C<53900
SET G=19
DO SET
QUIT
20 IF C>53999
IF C<55921
SET G=20
DO SET
QUIT
21 IF C=55970
SET G=21
DO SET
QUIT
+1 IF C=55980
SET G=21
DO SET
QUIT
22 IF C>56404
IF C<59000
SET G=22
DO SET
QUIT
23 IF C>58999
IF C<59900
SET G=23
DO SET
QUIT
24 IF C>59999
IF C<60700
SET G=24
DO SET
QUIT
25 IF C>60999
IF C<65000
SET G=25
DO SET
QUIT
26 IF C>65090
IF C<68900
SET G=26
DO SET
QUIT
27 IF C>68999
IF C<69980
SET G=27
DO SET
QUIT
28 IF C>70009
IF C<80000
SET G=28
DO SET
QUIT
29 IF C>80046
IF C<89357
SET G=29
DO SET
QUIT
+1 IF C=89398
SET G=29
DO SET
QUIT
30 IF C>90280
IF C<99092
SET G=30
DO SET
QUIT
+1 IF C>99169
IF C<99200
SET G=30
DO SET
QUIT
31 ;
32 ;
33 IF $EXTRACT(C,5)="T"
IF +C>15
SET G=33
DO SET
QUIT
44 SET G=44
DO SET
QUIT
+1 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 ;----------
+3 ;
FEEAMT(C,T) ;
+1 IF '$GET(T)
QUIT ""
+2 IF '$GET(C)
QUIT ""
+3 ;return fee amt for cpt ien C
+4 NEW X,A
+5 SET X=0
SET A=""
+6 FOR
SET X=$ORDER(^ABMDFEE(T,X))
IF X'=+X!(A]"")
QUIT
IF $DATA(^ABMDFEE(T,X,"B",C))
SET Y=$ORDER(^ABMDFEE(T,X,"B",C,0))
SET A=$PIECE(^ABMDFEE(T,X,Y,0),U,2)
+7 QUIT A
+8 ;
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 ;----------
O ;one location
+1 SET DIC="^AUTTLOC("
SET DIC(0)="AEMQ"
SET DIC("A")="Which LOCATION: "
DO ^DIC
KILL DIC
+2 IF Y=-1
SET APCLQ=""
QUIT
+3 SET APCLLOCT("ONE")=+Y
+4 QUIT
S ;all communities within APCLSU su
+1 SET DIC="^AUTTSU("
SET DIC("B")=$$VAL^XBDIQ1(9999999.06,DUZ(2),.05)
SET DIC(0)="AEMQ"
SET DIC("A")="Which SERVICE UNIT: "
DO ^DIC
KILL DIC
+2 IF Y=-1
SET APCLQ=""
QUIT
+3 SET APCLLOCT("SU")=+Y
+4 QUIT
+5 ;
