Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCLCAR2

APCLCAR2.m

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