IBJPS8 ;AITC/WCJ - IB Site Parameters, CMN CPT Inclusions CPT Codes ;02-Feb-2018
;;2.0;INTEGRATED BILLING;**608**;21-MAR-94;Build 90
;;Per VA Directive 6402, this routine should not be modified.
;
EN ; -- main entry point for IBJP IB CMN CPTS
D EN^VALM("IBJPS CMN CPTS")
Q
;
HDR ; -- header code
S VALMSG=""
Q
;
INIT ; -- init variables and list array
N ERROR,IBCNT,IBLN,IBSTR
N CPTDATA,CIENS,CPTIEN,RTYDSC
;
S (VALMCNT,IBCNT,IBLN)=0
I $D(^IBE(350.9,1,16,"B")) D
. S CPTIEN=0 F S CPTIEN=$O(^IBE(350.9,1,16,"B",CPTIEN)) Q:'CPTIEN D
. . ;
. . S CIENS=CPTIEN_","
. . D GETS^DIQ(81,CIENS,".001;.01;2","I","CPTDATA","ERROR")
. . S IBCNT=IBCNT+1
. . S IBSTR=$$SETSTR^VALM1($J(IBCNT,4)_".","",2,6)
. . S IBSTR=$$SETSTR^VALM1($G(CPTDATA(81,CIENS,.01,"I")),IBSTR,10,10)
. . S IBSTR=$$SETSTR^VALM1($G(CPTDATA(81,CIENS,2,"I")),IBSTR,25,30)
. . S IBLN=$$SET(IBLN,IBSTR)
. . S @VALMAR@("ZIDX",IBCNT,+CIENS)=""
. . Q
;
I 'IBLN S IBLN=$$SET(IBLN,$$SETSTR^VALM1("No CMN CPTs defined.","",13,40))
;
S VALMCNT=IBLN,VALMBG=1
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
D CLEAR^VALM1,CLEAN^VALM10
Q
;
EXPND ; -- expand code
Q
;
RTADD(IBTCFLAG) ; -- Add a new CPT Codes
N X,Y,DIE,DIR,DIRUT,DR,DTOUT,DUOUT,ERRMSG,FDA,RETIEN
;
S VALMBCK="R"
D FULL^VALM1
D RTADD1
D INIT
Q
;
RTADD1 ; Looping tag for Adding CPT Codes
K DA,DIE,DIR,DIRUT,DR,DTOUT,DUOUT,ERRMSG,FDA,RETIEN,X,Y
;
S DIR(0)="350.916,.01"
S DIR("A")="CPT Code"
D ^DIR
Q:'+Y
;
I $D(^IBE(350.9,1,16,"B",+Y)) D G RTADD1
. D FULL^VALM1
. W @IOF
. W !,"This CPT Code already exists on the Inclusion list."
. W !,"Please enter another CPT Code."
. Q
;
S FDA(350.916,"+1,1,",.01)=+Y
D UPDATE^DIE("","FDA","RETIEN","ERRMSG")
G RTADD1
;
RTDEL ; -- Delete a CPT Coode
N DR
D RTDEL1
S VALMBCK="R"
Q
;
RTDEL1 ; Looping tag for deleting CPT Codes
N Z,VALMY
D FULL^VALM1
D EN^VALM2($G(XQORNOD(0)))
S Z=0
F S Z=$O(VALMY(Z)) Q:'Z D
. N DIK,IEN,RIEN
. S IEN=$O(@VALMAR@("ZIDX",Z,""))
. Q:IEN=""
. S RIEN=$O(^IBE(350.9,1,16,"B",IEN,""))
. I +RIEN S DIK="^IBE(350.9,1,16,",DA(1)=1,DA=RIEN D ^DIK
K @VALMAR
D INIT
Q
;
SET(IBLN,IBSTR) ; -- Add a line to display list
; returns line number added
S IBLN=IBLN+1 D SET^VALM10(IBLN,IBSTR,IBLN)
Q IBLN
;
CMNPRMT(IBXIEN,IBPROCP,CPTIEN) ;JRA Determine if procedure requires prompting for CMN Info
;Basically checks if CPTIEN is in the "CMN CPT Code Inclusion" list
; Input: IBXIEN = Internal bill/claim number
; IBPROCP = Procedure line subscript
; CPTIEN = CPT code ien
;
; Output: 1 = Prompt user for CMN info
; 0 = Don't prompt user for CMN info
;
I '$G(IBXIEN)!('$G(IBPROCP)!('$G(CPTIEN))) Q 0
;Prompt if the CPT is in IB Site Parameters "CMN CPT Code Inclusion" list -OR- if "CMN Required?" already set to "YES"
I $D(^IBE(350.9,1,16,"B",CPTIEN))>1!($$CMNDATA^IBCEF31(IBXIEN,IBPROCP,23,"I")) Q 1
Q 0
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJPS8 3042 printed Oct 16, 2024@18:24:21 Page 2
IBJPS8 ;AITC/WCJ - IB Site Parameters, CMN CPT Inclusions CPT Codes ;02-Feb-2018
+1 ;;2.0;INTEGRATED BILLING;**608**;21-MAR-94;Build 90
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; -- main entry point for IBJP IB CMN CPTS
+1 DO EN^VALM("IBJPS CMN CPTS")
+2 QUIT
+3 ;
HDR ; -- header code
+1 SET VALMSG=""
+2 QUIT
+3 ;
INIT ; -- init variables and list array
+1 NEW ERROR,IBCNT,IBLN,IBSTR
+2 NEW CPTDATA,CIENS,CPTIEN,RTYDSC
+3 ;
+4 SET (VALMCNT,IBCNT,IBLN)=0
+5 IF $DATA(^IBE(350.9,1,16,"B"))
Begin DoDot:1
+6 SET CPTIEN=0
FOR
SET CPTIEN=$ORDER(^IBE(350.9,1,16,"B",CPTIEN))
if 'CPTIEN
QUIT
Begin DoDot:2
+7 ;
+8 SET CIENS=CPTIEN_","
+9 DO GETS^DIQ(81,CIENS,".001;.01;2","I","CPTDATA","ERROR")
+10 SET IBCNT=IBCNT+1
+11 SET IBSTR=$$SETSTR^VALM1($JUSTIFY(IBCNT,4)_".","",2,6)
+12 SET IBSTR=$$SETSTR^VALM1($GET(CPTDATA(81,CIENS,.01,"I")),IBSTR,10,10)
+13 SET IBSTR=$$SETSTR^VALM1($GET(CPTDATA(81,CIENS,2,"I")),IBSTR,25,30)
+14 SET IBLN=$$SET(IBLN,IBSTR)
+15 SET @VALMAR@("ZIDX",IBCNT,+CIENS)=""
+16 QUIT
End DoDot:2
End DoDot:1
+17 ;
+18 IF 'IBLN
SET IBLN=$$SET(IBLN,$$SETSTR^VALM1("No CMN CPTs defined.","",13,40))
+19 ;
+20 SET VALMCNT=IBLN
SET VALMBG=1
+21 QUIT
+22 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 DO CLEAR^VALM1
DO CLEAN^VALM10
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
RTADD(IBTCFLAG) ; -- Add a new CPT Codes
+1 NEW X,Y,DIE,DIR,DIRUT,DR,DTOUT,DUOUT,ERRMSG,FDA,RETIEN
+2 ;
+3 SET VALMBCK="R"
+4 DO FULL^VALM1
+5 DO RTADD1
+6 DO INIT
+7 QUIT
+8 ;
RTADD1 ; Looping tag for Adding CPT Codes
+1 KILL DA,DIE,DIR,DIRUT,DR,DTOUT,DUOUT,ERRMSG,FDA,RETIEN,X,Y
+2 ;
+3 SET DIR(0)="350.916,.01"
+4 SET DIR("A")="CPT Code"
+5 DO ^DIR
+6 if '+Y
QUIT
+7 ;
+8 IF $DATA(^IBE(350.9,1,16,"B",+Y))
Begin DoDot:1
+9 DO FULL^VALM1
+10 WRITE @IOF
+11 WRITE !,"This CPT Code already exists on the Inclusion list."
+12 WRITE !,"Please enter another CPT Code."
+13 QUIT
End DoDot:1
GOTO RTADD1
+14 ;
+15 SET FDA(350.916,"+1,1,",.01)=+Y
+16 DO UPDATE^DIE("","FDA","RETIEN","ERRMSG")
+17 GOTO RTADD1
+18 ;
RTDEL ; -- Delete a CPT Coode
+1 NEW DR
+2 DO RTDEL1
+3 SET VALMBCK="R"
+4 QUIT
+5 ;
RTDEL1 ; Looping tag for deleting CPT Codes
+1 NEW Z,VALMY
+2 DO FULL^VALM1
+3 DO EN^VALM2($GET(XQORNOD(0)))
+4 SET Z=0
+5 FOR
SET Z=$ORDER(VALMY(Z))
if 'Z
QUIT
Begin DoDot:1
+6 NEW DIK,IEN,RIEN
+7 SET IEN=$ORDER(@VALMAR@("ZIDX",Z,""))
+8 if IEN=""
QUIT
+9 SET RIEN=$ORDER(^IBE(350.9,1,16,"B",IEN,""))
+10 IF +RIEN
SET DIK="^IBE(350.9,1,16,"
SET DA(1)=1
SET DA=RIEN
DO ^DIK
End DoDot:1
+11 KILL @VALMAR
+12 DO INIT
+13 QUIT
+14 ;
SET(IBLN,IBSTR) ; -- Add a line to display list
+1 ; returns line number added
+2 SET IBLN=IBLN+1
DO SET^VALM10(IBLN,IBSTR,IBLN)
+3 QUIT IBLN
+4 ;
CMNPRMT(IBXIEN,IBPROCP,CPTIEN) ;JRA Determine if procedure requires prompting for CMN Info
+1 ;Basically checks if CPTIEN is in the "CMN CPT Code Inclusion" list
+2 ; Input: IBXIEN = Internal bill/claim number
+3 ; IBPROCP = Procedure line subscript
+4 ; CPTIEN = CPT code ien
+5 ;
+6 ; Output: 1 = Prompt user for CMN info
+7 ; 0 = Don't prompt user for CMN info
+8 ;
+9 IF '$GET(IBXIEN)!('$GET(IBPROCP)!('$GET(CPTIEN)))
QUIT 0
+10 ;Prompt if the CPT is in IB Site Parameters "CMN CPT Code Inclusion" list -OR- if "CMN Required?" already set to "YES"
+11 IF $DATA(^IBE(350.9,1,16,"B",CPTIEN))>1!($$CMNDATA^IBCEF31(IBXIEN,IBPROCP,23,"I"))
QUIT 1
+12 QUIT 0
+13 ;
