AUPNCPT ; IHS/CMI/LAB - CALCULATE CPT CODE ;
;;2.0;IHS PCC SUITE;**,11**;MAY 14, 2009;Build 58
;
;
;
CPT(V) ;PEP - get all cpts entered on this visit
;return 0 or error code
;error codes : 1 - no visit passed
; 2 - invalid/deleted visit entry passed
;return AUPNCPT( array in format:
; AUPNCPT(n)=cpt code^cpt narr^cpt ien^v file # from where the cpt code came^ien of v file entry^
;note: not all will have a v file entry #
; if no cpt codes available, array AUPNCPT will be undefined
;i=internal of cpt
;c=cpt cpt code
;e=ien of v file or visit
;n=text of cpt
;
I '$G(V) Q 1
I '$D(^AUPNVSIT(V)) Q 2
I $P(^AUPNVSIT(V,0),"^",11) Q 2
I '$P(^AUPNVSIT(V,0),"^",9) Q 2
NEW %,AUPNX,AUPNJ,AUPNT,AUPNY,%1,C,E,F,N,I,D,M,O
S (%,%1)=0
S D=$P($P(^AUPNVSIT(V,0),"^",1),".")
K AUPNCPT
S AUPNT="CPTS" F AUPNJ=1:1 S AUPNX=$T(@AUPNT+AUPNJ),AUPNY=$P(AUPNX,";;",3),F=$P(AUPNX,";;",2) Q:AUPNY="QUIT"!(AUPNY="") D @AUPNY
Q %
SET ;
S %1=%1+1
S AUPNCPT(%1)=C_"^"_N_"^"_I_"^"_F_"^"_E_"^"_M_"^"_O
Q
V ;visit cpt - eval&man
Q:$P(^AUPNVSIT(V,0),"^",17)=""
;S C=$$VAL^XBDIQ1(9000010,V,.17),E=V,N=$$VAL^XBDIQ1(81,$P(^AUPNVSIT(V,0),"^",17),2),I=$P(^AUPNVSIT(V,0),"^",17),(M,O)="" D SET
S C=$$VAL^XBDIQ1(9000010,V,.17),E=V
S N=$P($$CPT^ICPTCOD($P(^AUPNVSIT(V,0),"^",17),D),U,3)
S I=$P(^AUPNVSIT(V,0),"^",17),(M,O)="" D SET
Q
1 ;measurements
;S E=0,(M,O)="" F S E=$O(^AUPNVMSR("AD",V,E)) Q:E'=+E I $$VAL^XBDIQ1(9000010.01,E,.011)]"" S C=$$VAL^XBDIQ1(9000010.01,E,.011),I=$O(^ICPT("B",C,0)),N=$S(I:$P(^ICPT(I,0),"^",2),1:""),(M,O)="" D SET
Q
8 ;
; S E=0,(M,O)="" F S E=$O(^AUPNVPRC("AD",V,E)) Q:E'=+E I $$VAL^XBDIQ1(9000010.08,E,.16)]"" S C=$$VAL^XBDIQ1(9000010.08,E,.16), ; IHS/ASDST/GTH AUPN*99.1*7 02/15/2002 ; split from following line for length.
; I=$P(^AUPNVPRC(E,0),U,16),N=$P(^ICPT($P(^AUPNVPRC(E,0),U,16),0),U,2),(M,O)="" D SET ; IHS/ASDST/GTH AUPN*99.1*7 02/15/2002
S E=0,(M,O)="" F S E=$O(^AUPNVPRC("AD",V,E)) Q:E'=+E I $$VAL^XBDIQ1(9000010.08,E,.16)]"" D
.S I=$P(^AUPNVPRC(E,0),U,16)
.S C=$$VAL^XBDIQ1(9000010.08,E,.16)
.S N=$P($$CPT^ICPTCOD(I,D),U,3)
.S M=$P(^AUPNVPRC(E,0),U,17)
.S O=$P(^AUPNVPRC(E,0),U,18)
.D SET ; IHS/ASDST/GTH AUPN*99.1*7 02/15/2002
Q
11 ;
;S E=0,(M,O)="" F S E=$O(^AUPNVIMM("AD",V,E)) Q:E'=+E I $$VAL^XBDIQ1(9000010.11,E,.011)]"" S C=$$VAL^XBDIQ1(9000010.11,E,.011),I=$O(^ICPT("B",C,0)),N=$S(I:$P(^ICPT(I,0),"^",2),1:""),(M,O)="" D SET
Q
12 ;
;S E=0,(M,O)="" F S E=$O(^AUPNVSK("AD",V,E)) Q:E'=+E I $$VAL^XBDIQ1(9000010.12,E,.011)]"" S C=$$VAL^XBDIQ1(9000010.12,E,.011),I=$O(^ICPT("B",C,0)),N=$S(I:$P(^ICPT(I,0),"^",2),1:""),(M,O)="" D SET
Q
13 ;
;S E=0,(M,O)="" F S E=$O(^AUPNVXAM("AD",V,E)) Q:E'=+E I $$VAL^XBDIQ1(9000010.13,E,.011)]"" S C=$$VAL^XBDIQ1(9000010.13,E,.011),I=$O(^ICPT("B",C,0)),N=$S(I:$P(^ICPT(I,0),"^",2),1:""),(M,O)="" D SET
Q
15 ;
;S E=0,(M,O)="" F S E=$O(^AUPNVTRT("AD",V,E)) Q:E'=+E I $$VAL^XBDIQ1(9000010.15,E,.011)]"" S C=$$VAL^XBDIQ1(9000010.15,E,.011),I=$O(^ICPT("B",C,0)),N=$S(I:$P(^ICPT(I,0),"^",2),1:""),(M,O)="" D SET
Q
16 ;
;S E=0,(M,O)="" F S E=$O(^AUPNVPED("AD",V,E)) Q:E'=+E I $$VAL^XBDIQ1(9000010.16,E,.011)]"" S C=$$VAL^XBDIQ1(9000010.16,E,.011),I=$O(^ICPT("B",C,0)),N=$S(I:$P(^ICPT(I,0),"^",2),1:""),(M,O)="" D SET
Q
17 ;
;S E=0,(M,O)="" F S E=$O(^AUPNVPT("AD",V,E)) Q:E'=+E I $$VAL^XBDIQ1(9000010.17,E,.011)]"" S C=$$VAL^XBDIQ1(9000010.17,E,.011),I=$O(^ICPT("B",C,0)),N=$S(I:$P(^ICPT(I,0),"^",2),1:""),(M,O)="" D SET
;not yet ready
Q
18 ;
;S E=0,(M,O)="" F S E=$O(^AUPNVCPT("AD",V,E)) Q:E'=+E S C=$$VAL^XBDIQ1(9000010.18,E,.01),I=$P(^AUPNVCPT(E,0),U),N=$S(I:$P(^ICPT(I,0),"^",2),1:""),M=$P(^AUPNVCPT(E,0),U,8),O=$P(^AUPNVCPT(E,0),U,9) D SET
S E=0,(M,O)="" F S E=$O(^AUPNVCPT("AD",V,E)) Q:E'=+E S C=$$VAL^XBDIQ1(9000010.18,E,.01),I=$P(^AUPNVCPT(E,0),U),N=$P($$CPT^ICPTCOD(I,D),U,3),M=$P(^AUPNVCPT(E,0),U,8),O=$P(^AUPNVCPT(E,0),U,9) D SET
Q
22 ;
;S E=0,(M,O)="" F S E=$O(^AUPNVRAD("AD",V,E)) Q:E'=+E I $$VAL^XBDIQ1(9000010.22,E,.019)]"" S C=$$VAL^XBDIQ1(9000010.22,E,.019),I=$O(^ICPT("B",C,0)),N=$S(I:$P(^ICPT(I,0),"^",2),1:""),(M,O)="" D SET
S E=0,(M,O)="" F S E=$O(^AUPNVRAD("AD",V,E)) Q:E'=+E I $$VAL^XBDIQ1(9000010.22,E,.019)]"" S C=$$VAL^XBDIQ1(9000010.22,E,.019),I=$P($$CPT^ICPTCOD(C,D),U,1),N=$P($$CPT^ICPTCOD(I,D),"^",3),M=$P(^AUPNVRAD(E,0),U,7),O=$P(^AUPNVRAD(E,0),U,8) D SET
Q
EXAMCPT(E) ;EP called from .011 field of V EXAM
Q:'$G(E)
Q:'$D(^AUPNVXAM(E))
NEW A,%,%1,%2,%3,%4
S %=$P(^AUPNVXAM(E,0),"^"),%1=$P(^AUTTEXAM(%,0),"^",11)
I %1 Q $P(^ICPT(%1,0),"^")
I $P(^AUTTEXAM(%,0),"^",2)="01" D
.S %1=""
.Q:$P(^AUPNVXAM(E,0),"^",3)=""
.Q:$P(^AUPNVXAM(E,0),"^",2)=""
.S %2=$P(^AUPNVXAM(E,0),"^",2),%4=$P($P(^AUPNVSIT($P(^AUPNVXAM(E,0),"^",3),0),"^"),".")
.S A=$$AGE^AUPNPAT(%2,%4)
.S %3=$P(^AUPNPAT(%2,0),"^",2)
.I %4=%3 D Q
..S %1=""
..I A<1 S %1=99381 Q
..I A>0&(A<5) S %1=99382 Q
..I A>4&(A<12) S %1=99383 Q
..I A>11&(A<18) S %1=99384 Q
..I A>17&(A<40) S %1=99385 Q
..I A>39&(A<65) S %1=99386 Q
..I A>64 S %1=99387 Q
..Q
.S %1=$S(A<1:99391,A>0&(A<5):99392,A>4&(A<12):99393,A<18&(A>11):99394,A<40&(A>17):99395,A<65&(A>39):99396,A>64:99397,1:"")
Q %1
IMMCPT(E) ;EP - called from .011 Field of V Immunization
Q:'$G(E)
Q:'$D(^AUPNVIMM(E))
NEW A,%,%1
S %=$P(^AUPNVIMM(E,0),"^"),%1=$P(^AUTTIMM(%,0),"^",11)
I %1 Q $P(^ICPT(%1,0),"^")
I $P(^AUTTIMM(%,0),"^",3)=10 D
.S %1=""
.Q:$P(^AUPNVIMM(E,0),"^",3)=""
.Q:$P(^AUPNVIMM(E,0),"^",2)=""
.S A=$$AGE^AUPNPAT($P(^AUPNVIMM(E,0),"^",2),$P($P(^AUPNVSIT($P(^AUPNVIMM(E,0),"^",3),0),"."),"^"))
.I A<12 S %1=90744 Q
.I A>11&(A<20) S %1=90745 Q
.I A>19 S %1=90746
.Q
Q %1
EDUCCPT(E) ;EP - compute cpt code for education topic given
;if cpt code present in v file, use it and quit
;if time and ind/grp designation is present, use to calculate
;cpt code
;otherwise return NULL (should we return 99401)
Q:'$G(E)
Q:'$D(^AUPNVPED(E))
NEW %1
S %1=99401
I $P(^AUPNVPED(E,0),"^",9) Q $P(^ICPT($P(^AUPNVPED(E,0),"^",9),0),"^")
I $P(^AUPNVPED(E,0),"^",7)]"",$P(^(0),"^",8)]"" D Q %1
.I $P(^AUPNVPED(E,0),"^",7)="I",$P(^(0),"^",8)<16 S %1=99401 Q
.I $P(^AUPNVPED(E,0),"^",7)="I",$P(^(0),"^",8)>15&($P(^(0),"^",8)<31) S %1=99402 Q
.I $P(^AUPNVPED(E,0),"^",7)="I",$P(^(0),"^",8)>30&($P(^(0),"^",8)<46) S %1=99403 Q
.I $P(^AUPNVPED(E,0),"^",7)="I",$P(^(0),"^",8)>45 S %1=99404 Q
.I $P(^AUPNVPED(E,0),"^",7)="G",$P(^(0),"^",8)<31 S %1=99411 Q
.I $P(^AUPNVPED(E,0),"^",7)="G",$P(^(0),"^",8)>30 S %1=99412 Q
.Q
Q %1
;
CPTS ;
;;9000010;;V
;;9000010.01;;1
;;9000010.08;;8
;;9000010.11;;11
;;9000010.12;;12
;;9000010.13;;13
;;9000010.15;;15
;;9000010.16;;16
;;9000010.17;;17
;;9000010.18;;18
;;9000010.22;;22
;;QUIT
AUPNCPT ; IHS/CMI/LAB - CALCULATE CPT CODE ;
+1 ;;2.0;IHS PCC SUITE;**,11**;MAY 14, 2009;Build 58
+2 ;
+3 ;
+4 ;
CPT(V) ;PEP - get all cpts entered on this visit
+1 ;return 0 or error code
+2 ;error codes : 1 - no visit passed
+3 ; 2 - invalid/deleted visit entry passed
+4 ;return AUPNCPT( array in format:
+5 ; AUPNCPT(n)=cpt code^cpt narr^cpt ien^v file # from where the cpt code came^ien of v file entry^
+6 ;note: not all will have a v file entry #
+7 ; if no cpt codes available, array AUPNCPT will be undefined
+8 ;i=internal of cpt
+9 ;c=cpt cpt code
+10 ;e=ien of v file or visit
+11 ;n=text of cpt
+12 ;
+13 IF '$GET(V)
QUIT 1
+14 IF '$DATA(^AUPNVSIT(V))
QUIT 2
+15 IF $PIECE(^AUPNVSIT(V,0),"^",11)
QUIT 2
+16 IF '$PIECE(^AUPNVSIT(V,0),"^",9)
QUIT 2
+17 NEW %,AUPNX,AUPNJ,AUPNT,AUPNY,%1,C,E,F,N,I,D,M,O
+18 SET (%,%1)=0
+19 SET D=$PIECE($PIECE(^AUPNVSIT(V,0),"^",1),".")
+20 KILL AUPNCPT
+21 SET AUPNT="CPTS"
FOR AUPNJ=1:1
SET AUPNX=$TEXT(@AUPNT+AUPNJ)
SET AUPNY=$PIECE(AUPNX,";;",3)
SET F=$PIECE(AUPNX,";;",2)
IF AUPNY="QUIT"!(AUPNY="")
QUIT
DO @AUPNY
+22 QUIT %
SET ;
+1 SET %1=%1+1
+2 SET AUPNCPT(%1)=C_"^"_N_"^"_I_"^"_F_"^"_E_"^"_M_"^"_O
+3 QUIT
V ;visit cpt - eval&man
+1 IF $PIECE(^AUPNVSIT(V,0),"^",17)=""
QUIT
+2 ;S C=$$VAL^XBDIQ1(9000010,V,.17),E=V,N=$$VAL^XBDIQ1(81,$P(^AUPNVSIT(V,0),"^",17),2),I=$P(^AUPNVSIT(V,0),"^",17),(M,O)="" D SET
+3 SET C=$$VAL^XBDIQ1(9000010,V,.17)
SET E=V
+4 SET N=$PIECE($$CPT^ICPTCOD($PIECE(^AUPNVSIT(V,0),"^",17),D),U,3)
+5 SET I=$PIECE(^AUPNVSIT(V,0),"^",17)
SET (M,O)=""
DO SET
+6 QUIT
1 ;measurements
+1 ;S E=0,(M,O)="" F S E=$O(^AUPNVMSR("AD",V,E)) Q:E'=+E I $$VAL^XBDIQ1(9000010.01,E,.011)]"" S C=$$VAL^XBDIQ1(9000010.01,E,.011),I=$O(^ICPT("B",C,0)),N=$S(I:$P(^ICPT(I,0),"^",2),1:""),(M,O)="" D SET
+2 QUIT
8 ;
+1 ; S E=0,(M,O)="" F S E=$O(^AUPNVPRC("AD",V,E)) Q:E'=+E I $$VAL^XBDIQ1(9000010.08,E,.16)]"" S C=$$VAL^XBDIQ1(9000010.08,E,.16), ; IHS/ASDST/GTH AUPN*99.1*7 02/15/2002 ; split from following line for length.
+2 ; I=$P(^AUPNVPRC(E,0),U,16),N=$P(^ICPT($P(^AUPNVPRC(E,0),U,16),0),U,2),(M,O)="" D SET ; IHS/ASDST/GTH AUPN*99.1*7 02/15/2002
+3 SET E=0
SET (M,O)=""
FOR
SET E=$ORDER(^AUPNVPRC("AD",V,E))
IF E'=+E
QUIT
IF $$VAL^XBDIQ1(9000010.08,E,.16)]""
Begin DoDot:1
+4 SET I=$PIECE(^AUPNVPRC(E,0),U,16)
+5 SET C=$$VAL^XBDIQ1(9000010.08,E,.16)
+6 SET N=$PIECE($$CPT^ICPTCOD(I,D),U,3)
+7 SET M=$PIECE(^AUPNVPRC(E,0),U,17)
+8 SET O=$PIECE(^AUPNVPRC(E,0),U,18)
+9 ; IHS/ASDST/GTH AUPN*99.1*7 02/15/2002
DO SET
End DoDot:1
+10 QUIT
11 ;
+1 ;S E=0,(M,O)="" F S E=$O(^AUPNVIMM("AD",V,E)) Q:E'=+E I $$VAL^XBDIQ1(9000010.11,E,.011)]"" S C=$$VAL^XBDIQ1(9000010.11,E,.011),I=$O(^ICPT("B",C,0)),N=$S(I:$P(^ICPT(I,0),"^",2),1:""),(M,O)="" D SET
+2 QUIT
12 ;
+1 ;S E=0,(M,O)="" F S E=$O(^AUPNVSK("AD",V,E)) Q:E'=+E I $$VAL^XBDIQ1(9000010.12,E,.011)]"" S C=$$VAL^XBDIQ1(9000010.12,E,.011),I=$O(^ICPT("B",C,0)),N=$S(I:$P(^ICPT(I,0),"^",2),1:""),(M,O)="" D SET
+2 QUIT
13 ;
+1 ;S E=0,(M,O)="" F S E=$O(^AUPNVXAM("AD",V,E)) Q:E'=+E I $$VAL^XBDIQ1(9000010.13,E,.011)]"" S C=$$VAL^XBDIQ1(9000010.13,E,.011),I=$O(^ICPT("B",C,0)),N=$S(I:$P(^ICPT(I,0),"^",2),1:""),(M,O)="" D SET
+2 QUIT
15 ;
+1 ;S E=0,(M,O)="" F S E=$O(^AUPNVTRT("AD",V,E)) Q:E'=+E I $$VAL^XBDIQ1(9000010.15,E,.011)]"" S C=$$VAL^XBDIQ1(9000010.15,E,.011),I=$O(^ICPT("B",C,0)),N=$S(I:$P(^ICPT(I,0),"^",2),1:""),(M,O)="" D SET
+2 QUIT
16 ;
+1 ;S E=0,(M,O)="" F S E=$O(^AUPNVPED("AD",V,E)) Q:E'=+E I $$VAL^XBDIQ1(9000010.16,E,.011)]"" S C=$$VAL^XBDIQ1(9000010.16,E,.011),I=$O(^ICPT("B",C,0)),N=$S(I:$P(^ICPT(I,0),"^",2),1:""),(M,O)="" D SET
+2 QUIT
17 ;
+1 ;S E=0,(M,O)="" F S E=$O(^AUPNVPT("AD",V,E)) Q:E'=+E I $$VAL^XBDIQ1(9000010.17,E,.011)]"" S C=$$VAL^XBDIQ1(9000010.17,E,.011),I=$O(^ICPT("B",C,0)),N=$S(I:$P(^ICPT(I,0),"^",2),1:""),(M,O)="" D SET
+2 ;not yet ready
+3 QUIT
18 ;
+1 ;S E=0,(M,O)="" F S E=$O(^AUPNVCPT("AD",V,E)) Q:E'=+E S C=$$VAL^XBDIQ1(9000010.18,E,.01),I=$P(^AUPNVCPT(E,0),U),N=$S(I:$P(^ICPT(I,0),"^",2),1:""),M=$P(^AUPNVCPT(E,0),U,8),O=$P(^AUPNVCPT(E,0),U,9) D SET
+2 SET E=0
SET (M,O)=""
FOR
SET E=$ORDER(^AUPNVCPT("AD",V,E))
IF E'=+E
QUIT
SET C=$$VAL^XBDIQ1(9000010.18,E,.01)
SET I=$PIECE(^AUPNVCPT(E,0),U)
SET N=$PIECE($$CPT^ICPTCOD(I,D),U,3)
SET M=$PIECE(^AUPNVCPT(E,0),U,8)
SET O=$PIECE(^AUPNVCPT(E,0),U,9)
DO SET
+3 QUIT
22 ;
+1 ;S E=0,(M,O)="" F S E=$O(^AUPNVRAD("AD",V,E)) Q:E'=+E I $$VAL^XBDIQ1(9000010.22,E,.019)]"" S C=$$VAL^XBDIQ1(9000010.22,E,.019),I=$O(^ICPT("B",C,0)),N=$S(I:$P(^ICPT(I,0),"^",2),1:""),(M,O)="" D SET
+2 SET E=0
SET (M,O)=""
FOR
SET E=$ORDER(^AUPNVRAD("AD",V,E))
IF E'=+E
QUIT
IF $$VAL^XBDIQ1(9000010.22,E,.019)]""
SET C=$$VAL^XBDIQ1(9000010.22,E,.019)
SET I=$PIECE($$CPT^ICPTCOD(C,D),U,1)
SET N=$PIECE($$CPT^ICPTCOD(I,D),"^",3)
SET M=$PIECE(^AUPNVRAD(E,0),U,7)
SET O=$PIECE(^AUPNVRAD(E,0),U,8)
DO SET
+3 QUIT
EXAMCPT(E) ;EP called from .011 field of V EXAM
+1 IF '$GET(E)
QUIT
+2 IF '$DATA(^AUPNVXAM(E))
QUIT
+3 NEW A,%,%1,%2,%3,%4
+4 SET %=$PIECE(^AUPNVXAM(E,0),"^")
SET %1=$PIECE(^AUTTEXAM(%,0),"^",11)
+5 IF %1
QUIT $PIECE(^ICPT(%1,0),"^")
+6 IF $PIECE(^AUTTEXAM(%,0),"^",2)="01"
Begin DoDot:1
+7 SET %1=""
+8 IF $PIECE(^AUPNVXAM(E,0),"^",3)=""
QUIT
+9 IF $PIECE(^AUPNVXAM(E,0),"^",2)=""
QUIT
+10 SET %2=$PIECE(^AUPNVXAM(E,0),"^",2)
SET %4=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVXAM(E,0),"^",3),0),"^"),".")
+11 SET A=$$AGE^AUPNPAT(%2,%4)
+12 SET %3=$PIECE(^AUPNPAT(%2,0),"^",2)
+13 IF %4=%3
Begin DoDot:2
+14 SET %1=""
+15 IF A<1
SET %1=99381
QUIT
+16 IF A>0&(A<5)
SET %1=99382
QUIT
+17 IF A>4&(A<12)
SET %1=99383
QUIT
+18 IF A>11&(A<18)
SET %1=99384
QUIT
+19 IF A>17&(A<40)
SET %1=99385
QUIT
+20 IF A>39&(A<65)
SET %1=99386
QUIT
+21 IF A>64
SET %1=99387
QUIT
+22 QUIT
End DoDot:2
QUIT
+23 SET %1=$SELECT(A<1:99391,A>0&(A<5):99392,A>4&(A<12):99393,A<18&(A>11):99394,A<40&(A>17):99395,A<65&(A>39):99396,A>64:99397,1:"")
End DoDot:1
+24 QUIT %1
IMMCPT(E) ;EP - called from .011 Field of V Immunization
+1 IF '$GET(E)
QUIT
+2 IF '$DATA(^AUPNVIMM(E))
QUIT
+3 NEW A,%,%1
+4 SET %=$PIECE(^AUPNVIMM(E,0),"^")
SET %1=$PIECE(^AUTTIMM(%,0),"^",11)
+5 IF %1
QUIT $PIECE(^ICPT(%1,0),"^")
+6 IF $PIECE(^AUTTIMM(%,0),"^",3)=10
Begin DoDot:1
+7 SET %1=""
+8 IF $PIECE(^AUPNVIMM(E,0),"^",3)=""
QUIT
+9 IF $PIECE(^AUPNVIMM(E,0),"^",2)=""
QUIT
+10 SET A=$$AGE^AUPNPAT($PIECE(^AUPNVIMM(E,0),"^",2),$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVIMM(E,0),"^",3),0),"."),"^"))
+11 IF A<12
SET %1=90744
QUIT
+12 IF A>11&(A<20)
SET %1=90745
QUIT
+13 IF A>19
SET %1=90746
+14 QUIT
End DoDot:1
+15 QUIT %1
EDUCCPT(E) ;EP - compute cpt code for education topic given
+1 ;if cpt code present in v file, use it and quit
+2 ;if time and ind/grp designation is present, use to calculate
+3 ;cpt code
+4 ;otherwise return NULL (should we return 99401)
+5 IF '$GET(E)
QUIT
+6 IF '$DATA(^AUPNVPED(E))
QUIT
+7 NEW %1
+8 SET %1=99401
+9 IF $PIECE(^AUPNVPED(E,0),"^",9)
QUIT $PIECE(^ICPT($PIECE(^AUPNVPED(E,0),"^",9),0),"^")
+10 IF $PIECE(^AUPNVPED(E,0),"^",7)]""
IF $PIECE(^(0),"^",8)]""
Begin DoDot:1
+11 IF $PIECE(^AUPNVPED(E,0),"^",7)="I"
IF $PIECE(^(0),"^",8)<16
SET %1=99401
QUIT
+12 IF $PIECE(^AUPNVPED(E,0),"^",7)="I"
IF $PIECE(^(0),"^",8)>15&($PIECE(^(0),"^",8)<31)
SET %1=99402
QUIT
+13 IF $PIECE(^AUPNVPED(E,0),"^",7)="I"
IF $PIECE(^(0),"^",8)>30&($PIECE(^(0),"^",8)<46)
SET %1=99403
QUIT
+14 IF $PIECE(^AUPNVPED(E,0),"^",7)="I"
IF $PIECE(^(0),"^",8)>45
SET %1=99404
QUIT
+15 IF $PIECE(^AUPNVPED(E,0),"^",7)="G"
IF $PIECE(^(0),"^",8)<31
SET %1=99411
QUIT
+16 IF $PIECE(^AUPNVPED(E,0),"^",7)="G"
IF $PIECE(^(0),"^",8)>30
SET %1=99412
QUIT
+17 QUIT
End DoDot:1
QUIT %1
+18 QUIT %1
+19 ;
CPTS ;
+1 ;;9000010;;V
+2 ;;9000010.01;;1
+3 ;;9000010.08;;8
+4 ;;9000010.11;;11
+5 ;;9000010.12;;12
+6 ;;9000010.13;;13
+7 ;;9000010.15;;15
+8 ;;9000010.16;;16
+9 ;;9000010.17;;17
+10 ;;9000010.18;;18
+11 ;;9000010.22;;22
+12 ;;QUIT
