- 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 ---[H[J[2J[HVBECRPCH 2495 printed Mar 13, 2025@21:49:29 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
