VBECRPCH.m

VBECRPCH ; HOIFO/BNT - VBECS HCPCS Codes lookup;19 May 2004

 ;;2.0;VBEC;;Jun 05, 2015;Build 4

 ;

 ; Note: This routine supports data exchange with an FDA registered

 ; medical device. As such, it may not be changed in any way without

 ; prior written approval from the medical device manufacturer.

 ; 

 ; Integration Agreements:

 ; Reference to CPT CATEGORY file supported by IA #1587

 ; Reference to CPT file supported by IA #4776

 ; Reference to LIST^DIC supported by IA #2051

 ; Reference to $$FIND1^DIC supported by IA #2051

 ; Reference to $$CHARCHK^XOBVLIB supported by IA #4090

 ; Reference to $$CPT^ICPTCOD supported by IA #1995

 ;

 QUIT

 ;

 ; ---------------------------------------------------------------

 ;       Private Method Supports IA #4610

 ; ---------------------------------------------------------------

HCPCS(RESULTS) ; Get active HCPCS codes from the CPT file for Path/Lab CPT Categories

 ;

 N OUT,X

 S VBECCNT=0

 S RESULTS=$NA(^TMP("VBECHCPCS",$J))

 K @RESULTS,^TMP("DILIST",$J)

 D BEGROOT^VBECRPC("Root")

 S VBHPC=194

 ;The following lines were commented out to remove the lookup and switch to a hard coded variable.

 ;S VBHPC=$$FIND1^DIC(81.1,,,"PATHOLOGY AND LABORATORY SERVICES",,,"VBERR")

 ;I 'VBHPC!($D(VBERR)) D  Q

 ;. D ERROR^VBECRPC("Error collecting HCPCS data")

 ;. D ENDROOT^VBECRPC("Root")

 ;. Q

 S VBSCRN="N CPT S CPT=$$CPT^ICPTCOD(Y) I $P(CPT,U,4)="_VBHPC_",$P(CPT,U,7),$P(CPT,U,5)=""H"""

 D LIST^DIC(81,,.01,,,,,"D",VBSCRN,,.OUT,"VBERR")

 I $D(VBERR) D  Q

 . D ERROR^VBECRPC("Error collecting HCPCS data")

 . D ENDROOT^VBECRPC("Root")

 . Q

 ;Replace the next lines with code to call $$CPT^ICPTCOD(x) and get code and name.

 ;Use ^XTMP($J,"DILIST","ID",n,.01)=P2028 to get the code (28 characters)

 S VBB=0 F  S VBB=$O(^TMP("DILIST",$J,"ID",VBB)) Q:'VBB  S VBDATA=^TMP("DILIST",$J,"ID",VBB,.01) D

  . S VBDATA=$$CPT^ICPTCOD(VBDATA) Q:$P(VBDATA,"^")=-1

  . D ADD^VBECRPC("<HCPCS>")

  . D ADD^VBECRPC("<Code>"_$P(VBDATA,"^",2)_"</Code>")

  . D ADD^VBECRPC("<Name>"_$P(VBDATA,"^",3)_"</Name>")

  . D ADD^VBECRPC("</HCPCS>")

 ;S VBB=0 F  S VBB=$O(^TMP("DILIST",$J,"ID",VBB)) Q:'VBB  S VBDATA="" D

 ; . D ADD^VBECRPC("<HCPCS>")

 ; . F VBC=".01^Code","2^Name" D ADD^VBECRPC("<"_$P(VBC,"^",2)_">"_$$STRIPL^VBECRPC($$CHARCHK^XOBVLIB(^TMP("DILIST",$J,"ID",VBB,$P(VBC,"^"))))_"</"_$P(VBC,"^",2)_">")

 ; . D ADD^VBECRPC("</HCPCS>")

 D ENDROOT^VBECRPC("Root")

 K @OUT,VBB,VBC,VBDATA,VBECCNT,VBFLD,VBHPC,VBSCRN

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---VBECRPCH   2495     printed  Apr 09, 2024@21:45:39                                                                                                                                                                                                    Page 2

VBECRPCH  ; HOIFO/BNT - VBECS HCPCS Codes lookup;19 May 2004

 +1       ;;2.0;VBEC;;Jun 05, 2015;Build 4

 +2       ;

 +3       ; Note: This routine supports data exchange with an FDA registered

 +4       ; medical device. As such, it may not be changed in any way without

 +5       ; prior written approval from the medical device manufacturer.

 +6       ; 

 +7       ; Integration Agreements:

 +8       ; Reference to CPT CATEGORY file supported by IA #1587

 +9       ; Reference to CPT file supported by IA #4776

 +10      ; Reference to LIST^DIC supported by IA #2051

 +11      ; Reference to $$FIND1^DIC supported by IA #2051

 +12      ; Reference to $$CHARCHK^XOBVLIB supported by IA #4090

 +13      ; Reference to $$CPT^ICPTCOD supported by IA #1995

 +14      ;

 +15       QUIT 

 +16      ;

 +17      ; ---------------------------------------------------------------

 +18      ;       Private Method Supports IA #4610

 +19      ; ---------------------------------------------------------------

HCPCS(RESULTS) ; Get active HCPCS codes from the CPT file for Path/Lab CPT Categories

 +1       ;

 +2        NEW OUT,X

 +3        SET VBECCNT=0

 +4        SET RESULTS=$NAME(^TMP("VBECHCPCS",$JOB))

 +5        KILL @RESULTS,^TMP("DILIST",$JOB)

 +6        DO BEGROOT^VBECRPC("Root")

 +7        SET VBHPC=194

 +8       ;The following lines were commented out to remove the lookup and switch to a hard coded variable.

 +9       ;S VBHPC=$$FIND1^DIC(81.1,,,"PATHOLOGY AND LABORATORY SERVICES",,,"VBERR")

 +10      ;I 'VBHPC!($D(VBERR)) D  Q

 +11      ;. D ERROR^VBECRPC("Error collecting HCPCS data")

 +12      ;. D ENDROOT^VBECRPC("Root")

 +13      ;. Q

 +14       SET VBSCRN="N CPT S CPT=$$CPT^ICPTCOD(Y) I $P(CPT,U,4)="_VBHPC_",$P(CPT,U,7),$P(CPT,U,5)=""H"""

 +15       DO LIST^DIC(81,,.01,,,,,"D",VBSCRN,,.OUT,"VBERR")

 +16       IF $DATA(VBERR)

               Begin DoDot:1

 +17               DO ERROR^VBECRPC("Error collecting HCPCS data")

 +18               DO ENDROOT^VBECRPC("Root")

 +19               QUIT 

               End DoDot:1

               QUIT 

 +20      ;Replace the next lines with code to call $$CPT^ICPTCOD(x) and get code and name.

 +21      ;Use ^XTMP($J,"DILIST","ID",n,.01)=P2028 to get the code (28 characters)

 +22       SET VBB=0

           FOR 

               SET VBB=$ORDER(^TMP("DILIST",$JOB,"ID",VBB))

               if 'VBB

                   QUIT 

               SET VBDATA=^TMP("DILIST",$JOB,"ID",VBB,.01)

               Begin DoDot:1

 +23               SET VBDATA=$$CPT^ICPTCOD(VBDATA)

                   if $PIECE(VBDATA,"^")=-1

                       QUIT 

 +24               DO ADD^VBECRPC("<HCPCS>")

 +25               DO ADD^VBECRPC("<Code>"_$PIECE(VBDATA,"^",2)_"</Code>")

 +26               DO ADD^VBECRPC("<Name>"_$PIECE(VBDATA,"^",3)_"</Name>")

 +27               DO ADD^VBECRPC("</HCPCS>")

               End DoDot:1

 +28      ;S VBB=0 F  S VBB=$O(^TMP("DILIST",$J,"ID",VBB)) Q:'VBB  S VBDATA="" D

 +29      ; . D ADD^VBECRPC("<HCPCS>")

 +30      ; . F VBC=".01^Code","2^Name" D ADD^VBECRPC("<"_$P(VBC,"^",2)_">"_$$STRIPL^VBECRPC($$CHARCHK^XOBVLIB(^TMP("DILIST",$J,"ID",VBB,$P(VBC,"^"))))_"</"_$P(VBC,"^",2)_">")

 +31      ; . D ADD^VBECRPC("</HCPCS>")

 +32       DO ENDROOT^VBECRPC("Root")

 +33       KILL @OUT,VBB,VBC,VBDATA,VBECCNT,VBFLD,VBHPC,VBSCRN

 +34       QUIT