AUPNCPT.m

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