IBCSCH2 ;ALB/DLS - Continuation of routine IBCSCH ;12 JUN 2007
;;2.0;INTEGRATED BILLING;**374,623**;21-MAR-94;Build 70
;;Per VA Directive 6402, this routine should not be modified.
Q
;
DISPPRV(IBIFN) ; Display provider information: interactive - user selects provider
N DIC,DA,X,Y,IBI,IBJ,IBW,IBPRV,IBPX,IBDT,IBARR,IBNPISTR,IBNPI,IBPRVTAX,IBTAXFLG
N IBPRVDAT,IBTAXID,IBTAXEFF,IBTAXTRM,IBTAXX12
W !!,"This is a display of provider specific information."
D SPECIFIC^IBCEU5(IBIFN)
S IBDT=+$G(^DGCR(399,+$G(IBIFN),"U")) I 'IBDT S IBDT=DT
;
F IBI=1:1 W ! S DIC("A")="Select PROVIDER NAME: ",DIC="^VA(200,",DIC(0)="AEQM" D ^DIC Q:Y'>0 D
. S IBPRV=Y
. W !!,$TR($J(" ",IOM)," ","-")
. S IBPX=$$ESBLOCK^XUSESIG1(+IBPRV)
. W !," Signature Name: ",$P(IBPX,U,1)
. W !,"Signature Title: ",$P(IBPX,U,3)
. W !," Degree: ",$P(IBPX,U,2)
. ;
. ; PRXM/DLS - Patch 374. Adding NPI to Signature information.
. S IBNPISTR=$$NPI^XUSNPI("Individual_ID",+IBPRV) ; Get NPI information.
. S IBNPI=$P(IBNPISTR,U) ; Get NPI.
. W !," NPI: ",$S(IBNPI>0:IBNPI,1:"") ; Write NPI.
. ;
. S IBPX=$$PRVLIC^IBCU1(+IBPRV,IBDT,.IBARR) ; Get License Info.
. W !!," License(s): " D
. . I IBPX'>0 W "None Active on ",$$FMTE^XLFDT(IBDT,2) Q
. . S IBJ=0,IBW=0 F S IBJ=$O(IBARR(IBJ)) Q:'IBJ D
. . . S IBPX=IBARR(IBJ),IBPX=$P($G(^DIC(5,+IBPX,0)),U,2)_": "_$P(IBPX,U,2)
. . . I (IBW+$L(IBPX))>61 W !,?17 S IBW=0
. . . W IBPX," " S IBW=IBW+$L(IBPX)+2
. ;
. ; PRXM/DLS - Display Person Class/Taxonomy Information.
. S IBTAXFLG=0 ; Init to 0, set to 1 if Person Class info found.
. S IBPRVTAX=0 ; Loop through prov's Person Class entries.
. F S IBPRVTAX=$O(^VA(200,+IBPRV,"USC1",IBPRVTAX)) Q:'IBPRVTAX D
. . ; Get Basic Information
. . S IBTAXID=$$GET1^DIQ(200.05,IBPRVTAX_","_+IBPRV_",",.01,"I") Q:IBTAXID="" ; Person Class IEN.
. . S IBTAXEFF=$$GET1^DIQ(200.05,IBPRVTAX_","_+IBPRV_",",2,"I") ; Person Class Eff Date.
. . S IBTAXTRM=$$GET1^DIQ(200.05,IBPRVTAX_","_+IBPRV_",",3,"I") ;I IBTAXTRM="" ; Person Class Term Date.
. . I IBTAXTRM="" S IBTAXTRM=9999999
. . ; See if claim beginning service date falls within Eff date range. If so, proceed.
. . I (IBTAXEFF'>IBDT),(IBTAXTRM>IBDT) D
. . . S IBTAXFLG=1 ; A Person Class found, set flag to 1.
. . . ; Get Detailed Information and Display.
. . . S IBPX=$$IEN2DATA^XUA4A72(IBTAXID) ; Person Class Details.
. . . S IBTAXX12=$$GET1^DIQ(8932.1,IBTAXID_",",6) ; Get X12 Code.
. . . W !
. . . W !," Person Class: ",$P(IBPX,U,6) ; Display Person Class Name.
. . . W !," PROVIDER TYPE: ",$P(IBPX,U) ; Display Provider Type.
. . . W !," CLASSIFICATION: ",$P(IBPX,U,2) ; Display Classification.
. . . W !," SPECIALIZATION: ",$P(IBPX,U,3) ; Display Specialization.
. . . W !," TAXONOMY: ",IBTAXX12,$S(IBTAXX12'="":" ("_IBTAXID_")",1:"") ; Display X12 Code and Internal Code (IEN).
. . . W !," EFFECTIVE: ",$$FMTE^XLFDT(IBTAXEFF,2) ; Display EFF Date.
. . . I IBTAXTRM'=9999999 W " - ",$$FMTE^XLFDT(IBTAXTRM,2) ; Display TRM Date, if it exists.
. ; If no Person Class entries exists for this Provider, notate it.
. I 'IBTAXFLG W !!," Person Class: None Active on ",$$FMTE^XLFDT(IBDT,2)
. S IBPX=$$PRVTYP^IBCRU6(+IBPRV,+IBDT)
. W !!,"RC Provider Group: ",$S(+IBPX:$P(IBPX,U,3)_", "_$P(IBPX,U,5)_"%",1:"None")
. W !,$TR($J(" ",IOM)," ","-")
Q
;
DISPNVA(IBIFN) ; Display Non-VA individual provider information.
N IBDT,IBI,IBNVFLG,IBNVID,IBNVTX,IBNVTX2,IBNVTXID,IBNVSL,X,Y,DIC,DA,IBTAXX12,IBPX
S IBDT=+$G(^DGCR(399,+$G(IBIFN),"U")) I 'IBDT S IBDT=DT
; Select Non-VA Provider
F IBI=1:1 W ! S DIC("A")="Select NON-VA PROVIDER NAME: ",DIC="^IBA(355.93,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,2)=2" D ^DIC Q:Y'>0 D
. S IBNVID=+Y W !!,$TR($J(" ",IOM)," ","-")
. W !," Signature Name: ",$$GET1^DIQ(355.93,IBNVID_",",.01)
. W !," NPI: ",$$GET1^DIQ(355.93,IBNVID_",",41.01)
. W !
. S IBNVSL=$$GET1^DIQ(355.93,IBNVID_",",.12) ; Get and Display License info.
. W !," License(s): ",$S(IBNVSL'="":IBNVSL,1:"None Active on "_$$FMTE^XLFDT(IBDT,2))
. W !
. S IBNVTX=""
. S IBNVFLG=0
. F S IBNVTX=$O(^IBA(355.93,IBNVID,"TAXONOMY","D",IBNVTX),-1) Q:IBNVTX="" D ; Loop through prov's Person Class X-Ref.
. . S IBNVTX2=""
. . F S IBNVTX2=$O(^IBA(355.93,IBNVID,"TAXONOMY","D",IBNVTX,IBNVTX2)) Q:'IBNVTX2 D
. . . I $$GET1^DIQ(355.9342,IBNVTX2_","_IBNVID_",",.03,"I")="A" D ; Proceed if the Person Class is Active.
. . . . S IBNVFLG=1
. . . . S IBNVTXID=$$GET1^DIQ(355.9342,IBNVTX2_","_IBNVID_",",.01,"I")
. . . . ; Get Detailed Information and Display.
. . . . S IBPX=$$IEN2DATA^XUA4A72(IBNVTXID) ; Person Class Details.
. . . . S IBTAXX12=$$GET1^DIQ(8932.1,IBNVTXID_",",6) ; Get X12 Code.
. . . . W !," Person Class: ",$P(IBPX,U,6) ; Display Person Class Name.
. . . . W $S($G(IBNVTX)=1:" (Primary)",1:" (Secondary)")
. . . . W !," PROVIDER TYPE: ",$P(IBPX,U) ; Display Provider Type.
. . . . W !," CLASSIFICATION: ",$P(IBPX,U,2) ; Display Classification.
. . . . W !," SPECIALIZATION: ",$P(IBPX,U,3) ; Display Specialization.
. . . . W !," TAXONOMY: ",IBTAXX12,$S(IBTAXX12'="":" ("_IBNVTXID_")",1:""),! ; Display X12 Code and Internal Code (IEN).
. I 'IBNVFLG W !," Person Class: None Active on ",$$FMTE^XLFDT(IBDT,2),!
. W $TR($J(" ",IOM)," ","-"),!
Q
;
;/vd - IB*2.0*623 (US4055) - Beginning.
DENTAL(IBIFN) ; Select Dental Claim detail gathered and displayed here
Q:'$G(IBIFN)
N ARY,CPTMOD,I,IBLC,IBLIN,IBQ,IBRORA,IBRORARES,IBRORATX,IBX,IBXDATA,L,N,NN,NPI,NUM,POS,PRVARY,SEQ,T,T1,T2,XABCD,XIBI,XDIAG
K ^TMP("IBXSAVE",$J),^TMP("IBXDISP",$J)
S IBLIN=$$BOX24D^IBCEF11()
S IBX=$$BILLN^IBCEFG0(0,"1^99",IBLIN,+IBIFN,2) ;Set ^TMP("IBXDISP",$J) w/ data for Diagnosis display
D OUTPT^IBCEF11(IBIFN,1) ;Gather procedure-level Dental data - stored in IBXDATA array
D GETPROVS(IBIFN,.PRVARY) ;Get the Provider Types.
;Output claim-level information
W @IOF,"Example of dx, procedures, teeth info, and charges entered on the Dental claim"
W !,"--------------------------------------------------------------------------------"
W !,"Claim Provider:"
S IBRORA=0
I $D(PRVARY) D ; Display the Provider Types & their IDs.
. W !
. S POS=0,SEQ=""
. F S SEQ=$O(PRVARY("SQ",SEQ)) Q:SEQ="" D
. . W ?POS,PRVARY("SQ",SEQ) S POS=POS+$L(PRVARY("SQ",SEQ))+5
;
;Output diagnosis codes using ^TMP("IBXDISP",$J) created by $$BILLN^IBCEFG0 function
W !!,"34a. Diagnosis:"
F L=3,4,5 D
.Q:(L'=3) ; Due to a request by eBiz...only 4 diagnosis codes should display on a Dental Claim (US4055).
.W !
.F T=3,16,29,42 D
..S NUM=""
..I L=3 S NUM=$S(T=3:1,T=16:2,T=29:3,T=42:4,1:"")
..S T2=T+2,T1=T I NUM>9 S T1=T-1
..W ?T1,NUM,".",?T2,$G(^TMP("IBXDISP",$J,1,IBLIN+L,T))
W !,"35. Dental Claim Note:"
W !,$$GET1^DIQ(399,IBIFN,97)
;
W ! D PG S IBLC=13
;Order thru IBXDATA array to output procedure-level data
S ARY="TMP(""IBXDATA"",$J)" K @ARY
I $D(IBXDATA)>1 S N="" F S N=$O(IBXDATA(N)) Q:N="" D
. S @ARY@(N,"POS")=$P($G(IBXDATA(N)),U,3)
. S @ARY@(N,"CPT")=$P($G(IBXDATA(N)),U,5)
. S XIBI=+$G(IBXDATA(N,"CPLNK"))
. S XDIAG=$P($G(IBXDATA(N)),U,7),XABCD=""
. F I=1:1:4 I +$P(XDIAG,",",I),$P(XDIAG,",",I)<5 S XABCD=XABCD_$TR($P(XDIAG,",",I),"1234,","ABCD")
. S @ARY@(N,"DIAG")=XABCD
. S @ARY@(N,"QTY")=$P($G(IBXDATA(N)),U,9)
. S @ARY@(N,"CHARGE")=$P($G(IBXDATA(N)),U,8)*@ARY@(N,"QTY")*100
. S CPTMOD=$P($G(IBXDATA(N)),U,10) I $TR(CPTMOD,",")]"" F I=1:1:$L(CPTMOD,",") D
. . Q:$P(CPTMOD,",",I)=""
. . S $P(CPTMOD,",",I)=$P($G(^DIC(81.3,$P(CPTMOD,",",I),0)),U)
. . S @ARY@(N,"CPTMOD")=$TR(CPTMOD,","," ")
. S @ARY@(N,"ORALCAV")=$TR($P($G(IBXDATA(N,"DEN")),U,1,5),U," ")
. ;
. S @ARY@(N,"START")=$E($P($G(IBXDATA(N)),U,1),1,2)_" "_$E($P($G(IBXDATA(N)),U,1),3,4)_" "_$E($P($G(IBXDATA(N)),U,1),7,8)
. S @ARY@(N,"END")=$E($P($G(IBXDATA(N)),U,2),1,2)_" "_$E($P($G(IBXDATA(N)),U,2),3,4)_" "_$E($P($G(IBXDATA(N)),U,2),7,8)
. I $P($G(IBXDATA(N)),U,2)="" S @ARY@(N,"END")=@ARY@(N,"START")
. ;
. S NN=0 F S NN=$O(IBXDATA(N,"DEN1",NN)) Q:NN="" I NN?1.N D
. . S @ARY@(N,NN,"TOOTH")=$P($G(IBXDATA(N,"DEN1",NN,0)),U)
. . S @ARY@(N,NN,"SURFACE")=$TR($P($G(IBXDATA(N,"DEN1",NN,0)),U,2,6),U)
;
S N="" F S N=$O(@ARY@(N)) Q:N="" D
. W !,@ARY@(N,"START"),?9,@ARY@(N,"END"),?18,@ARY@(N,"ORALCAV")
. W ?33,$G(@ARY@(N,1,"TOOTH")),?36,$G(@ARY@(N,1,"SURFACE")),?42,$G(@ARY@(N,"CPT"))
. W ?48,$G(@ARY@(N,"CPTMOD")),?60,$G(@ARY@(N,"DIAG")),?65,$G(@ARY@(N,"QTY")),?68,$G(@ARY@(N,"CHARGE")),?77,@ARY@(N,"POS")
. S IBLC=IBLC+1 I IBLC>20,($O(@ARY@(N))!($O(@ARY@(N,1)))) W !,$TR($J("-",80)," ","-") S IBQ=$$PAUSE^IBCSCH1(IBLC) Q:IBQ W @IOF D PG
. S NN=1 F S NN=$O(@ARY@(N,NN)) Q:NN="" D
. . I $G(@ARY@(N,NN,"TOOTH"))="",($G(@ARY@(N,NN,"SURFACE")))="" Q
. . W !,?33,$G(@ARY@(N,NN,"TOOTH")),?36,$G(@ARY@(N,NN,"SURFACE"))
. . S IBLC=IBLC+1 I IBLC>20,$O(@ARY@(N,NN)) W !,$TR($J("-",80)," ","-") I S IBQ=$$PAUSE^IBCSCH1(IBLC) Q:IBQ W @IOF D PG
W !,"--------------------------------------------------------------------------------"
S IBQ=$$PAUSE^IBCSCH1(IBLC)
K @ARY
Q
;
GETPROVS(IBIFN,PRVARY) ;Get the Provider Types
N FILE,FLD,PROV,SQ,TYPE,UCTYPE
K PRVARY
Q:'IBIFN
S TYPE=""
F S TYPE=$O(^DGCR(399,IBIFN,"PRV","C",TYPE)) Q:TYPE="" D
. S UCTYPE=$$UP^XLFSTR(TYPE)
. I UCTYPE="ASSISTANT SURGEON" S UCTYPE="ASST SURGEON"
. I $D(PRVARY("P",UCTYPE)) Q ; Already have capitalized version of this Provider Type.
. S SQ=$O(^DGCR(399,IBIFN,"PRV","C",TYPE,"")) Q:SQ=""
. S FILE=+$P($P($G(^DGCR(399,IBIFN,"PRV",SQ,0)),U,2),"(",2)
. S PROV=$P($P($G(^DGCR(399,IBIFN,"PRV",SQ,0)),U,2),";")
. S FLD=$S(FILE["355.93":41.01,1:41.99)
. S NPI=$$GET1^DIQ(FILE,PROV,FLD) S:$TR(NPI," ")="" NPI="**NO NPI**"
. S PRVARY("P",UCTYPE)=SQ,PRVARY("SQ",SQ)=UCTYPE_"/"_NPI
Q
;
PG ; Display Dental form box numbers at top of charge list
W "24 25 27 28 29 29a 29b 31 38"
W !,"--------------------------------------------------------------------------------"
S IBLC=3
Q
;/vd - IB*2.0*623 (US4055) - End.
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSCH2 11105 printed Dec 13, 2024@02:20:31 Page 2
IBCSCH2 ;ALB/DLS - Continuation of routine IBCSCH ;12 JUN 2007
+1 ;;2.0;INTEGRATED BILLING;**374,623**;21-MAR-94;Build 70
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
DISPPRV(IBIFN) ; Display provider information: interactive - user selects provider
+1 NEW DIC,DA,X,Y,IBI,IBJ,IBW,IBPRV,IBPX,IBDT,IBARR,IBNPISTR,IBNPI,IBPRVTAX,IBTAXFLG
+2 NEW IBPRVDAT,IBTAXID,IBTAXEFF,IBTAXTRM,IBTAXX12
+3 WRITE !!,"This is a display of provider specific information."
+4 DO SPECIFIC^IBCEU5(IBIFN)
+5 SET IBDT=+$GET(^DGCR(399,+$GET(IBIFN),"U"))
IF 'IBDT
SET IBDT=DT
+6 ;
+7 FOR IBI=1:1
WRITE !
SET DIC("A")="Select PROVIDER NAME: "
SET DIC="^VA(200,"
SET DIC(0)="AEQM"
DO ^DIC
if Y'>0
QUIT
Begin DoDot:1
+8 SET IBPRV=Y
+9 WRITE !!,$TRANSLATE($JUSTIFY(" ",IOM)," ","-")
+10 SET IBPX=$$ESBLOCK^XUSESIG1(+IBPRV)
+11 WRITE !," Signature Name: ",$PIECE(IBPX,U,1)
+12 WRITE !,"Signature Title: ",$PIECE(IBPX,U,3)
+13 WRITE !," Degree: ",$PIECE(IBPX,U,2)
+14 ;
+15 ; PRXM/DLS - Patch 374. Adding NPI to Signature information.
+16 ; Get NPI information.
SET IBNPISTR=$$NPI^XUSNPI("Individual_ID",+IBPRV)
+17 ; Get NPI.
SET IBNPI=$PIECE(IBNPISTR,U)
+18 ; Write NPI.
WRITE !," NPI: ",$SELECT(IBNPI>0:IBNPI,1:"")
+19 ;
+20 ; Get License Info.
SET IBPX=$$PRVLIC^IBCU1(+IBPRV,IBDT,.IBARR)
+21 WRITE !!," License(s): "
Begin DoDot:2
+22 IF IBPX'>0
WRITE "None Active on ",$$FMTE^XLFDT(IBDT,2)
QUIT
+23 SET IBJ=0
SET IBW=0
FOR
SET IBJ=$ORDER(IBARR(IBJ))
if 'IBJ
QUIT
Begin DoDot:3
+24 SET IBPX=IBARR(IBJ)
SET IBPX=$PIECE($GET(^DIC(5,+IBPX,0)),U,2)_": "_$PIECE(IBPX,U,2)
+25 IF (IBW+$LENGTH(IBPX))>61
WRITE !,?17
SET IBW=0
+26 WRITE IBPX," "
SET IBW=IBW+$LENGTH(IBPX)+2
End DoDot:3
End DoDot:2
+27 ;
+28 ; PRXM/DLS - Display Person Class/Taxonomy Information.
+29 ; Init to 0, set to 1 if Person Class info found.
SET IBTAXFLG=0
+30 ; Loop through prov's Person Class entries.
SET IBPRVTAX=0
+31 FOR
SET IBPRVTAX=$ORDER(^VA(200,+IBPRV,"USC1",IBPRVTAX))
if 'IBPRVTAX
QUIT
Begin DoDot:2
+32 ; Get Basic Information
+33 ; Person Class IEN.
SET IBTAXID=$$GET1^DIQ(200.05,IBPRVTAX_","_+IBPRV_",",.01,"I")
if IBTAXID=""
QUIT
+34 ; Person Class Eff Date.
SET IBTAXEFF=$$GET1^DIQ(200.05,IBPRVTAX_","_+IBPRV_",",2,"I")
+35 ;I IBTAXTRM="" ; Person Class Term Date.
SET IBTAXTRM=$$GET1^DIQ(200.05,IBPRVTAX_","_+IBPRV_",",3,"I")
+36 IF IBTAXTRM=""
SET IBTAXTRM=9999999
+37 ; See if claim beginning service date falls within Eff date range. If so, proceed.
+38 IF (IBTAXEFF'>IBDT)
IF (IBTAXTRM>IBDT)
Begin DoDot:3
+39 ; A Person Class found, set flag to 1.
SET IBTAXFLG=1
+40 ; Get Detailed Information and Display.
+41 ; Person Class Details.
SET IBPX=$$IEN2DATA^XUA4A72(IBTAXID)
+42 ; Get X12 Code.
SET IBTAXX12=$$GET1^DIQ(8932.1,IBTAXID_",",6)
+43 WRITE !
+44 ; Display Person Class Name.
WRITE !," Person Class: ",$PIECE(IBPX,U,6)
+45 ; Display Provider Type.
WRITE !," PROVIDER TYPE: ",$PIECE(IBPX,U)
+46 ; Display Classification.
WRITE !," CLASSIFICATION: ",$PIECE(IBPX,U,2)
+47 ; Display Specialization.
WRITE !," SPECIALIZATION: ",$PIECE(IBPX,U,3)
+48 ; Display X12 Code and Internal Code (IEN).
WRITE !," TAXONOMY: ",IBTAXX12,$SELECT(IBTAXX12'="":" ("_IBTAXID_")",1:"")
+49 ; Display EFF Date.
WRITE !," EFFECTIVE: ",$$FMTE^XLFDT(IBTAXEFF,2)
+50 ; Display TRM Date, if it exists.
IF IBTAXTRM'=9999999
WRITE " - ",$$FMTE^XLFDT(IBTAXTRM,2)
End DoDot:3
End DoDot:2
+51 ; If no Person Class entries exists for this Provider, notate it.
+52 IF 'IBTAXFLG
WRITE !!," Person Class: None Active on ",$$FMTE^XLFDT(IBDT,2)
+53 SET IBPX=$$PRVTYP^IBCRU6(+IBPRV,+IBDT)
+54 WRITE !!,"RC Provider Group: ",$SELECT(+IBPX:$PIECE(IBPX,U,3)_", "_$PIECE(IBPX,U,5)_"%",1:"None")
+55 WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","-")
End DoDot:1
+56 QUIT
+57 ;
DISPNVA(IBIFN) ; Display Non-VA individual provider information.
+1 NEW IBDT,IBI,IBNVFLG,IBNVID,IBNVTX,IBNVTX2,IBNVTXID,IBNVSL,X,Y,DIC,DA,IBTAXX12,IBPX
+2 SET IBDT=+$GET(^DGCR(399,+$GET(IBIFN),"U"))
IF 'IBDT
SET IBDT=DT
+3 ; Select Non-VA Provider
+4 FOR IBI=1:1
WRITE !
SET DIC("A")="Select NON-VA PROVIDER NAME: "
SET DIC="^IBA(355.93,"
SET DIC(0)="AEQM"
SET DIC("S")="I $P(^(0),U,2)=2"
DO ^DIC
if Y'>0
QUIT
Begin DoDot:1
+5 SET IBNVID=+Y
WRITE !!,$TRANSLATE($JUSTIFY(" ",IOM)," ","-")
+6 WRITE !," Signature Name: ",$$GET1^DIQ(355.93,IBNVID_",",.01)
+7 WRITE !," NPI: ",$$GET1^DIQ(355.93,IBNVID_",",41.01)
+8 WRITE !
+9 ; Get and Display License info.
SET IBNVSL=$$GET1^DIQ(355.93,IBNVID_",",.12)
+10 WRITE !," License(s): ",$SELECT(IBNVSL'="":IBNVSL,1:"None Active on "_$$FMTE^XLFDT(IBDT,2))
+11 WRITE !
+12 SET IBNVTX=""
+13 SET IBNVFLG=0
+14 ; Loop through prov's Person Class X-Ref.
FOR
SET IBNVTX=$ORDER(^IBA(355.93,IBNVID,"TAXONOMY","D",IBNVTX),-1)
if IBNVTX=""
QUIT
Begin DoDot:2
+15 SET IBNVTX2=""
+16 FOR
SET IBNVTX2=$ORDER(^IBA(355.93,IBNVID,"TAXONOMY","D",IBNVTX,IBNVTX2))
if 'IBNVTX2
QUIT
Begin DoDot:3
+17 ; Proceed if the Person Class is Active.
IF $$GET1^DIQ(355.9342,IBNVTX2_","_IBNVID_",",.03,"I")="A"
Begin DoDot:4
+18 SET IBNVFLG=1
+19 SET IBNVTXID=$$GET1^DIQ(355.9342,IBNVTX2_","_IBNVID_",",.01,"I")
+20 ; Get Detailed Information and Display.
+21 ; Person Class Details.
SET IBPX=$$IEN2DATA^XUA4A72(IBNVTXID)
+22 ; Get X12 Code.
SET IBTAXX12=$$GET1^DIQ(8932.1,IBNVTXID_",",6)
+23 ; Display Person Class Name.
WRITE !," Person Class: ",$PIECE(IBPX,U,6)
+24 WRITE $SELECT($GET(IBNVTX)=1:" (Primary)",1:" (Secondary)")
+25 ; Display Provider Type.
WRITE !," PROVIDER TYPE: ",$PIECE(IBPX,U)
+26 ; Display Classification.
WRITE !," CLASSIFICATION: ",$PIECE(IBPX,U,2)
+27 ; Display Specialization.
WRITE !," SPECIALIZATION: ",$PIECE(IBPX,U,3)
+28 ; Display X12 Code and Internal Code (IEN).
WRITE !," TAXONOMY: ",IBTAXX12,$SELECT(IBTAXX12'="":" ("_IBNVTXID_")",1:""),!
End DoDot:4
End DoDot:3
End DoDot:2
+29 IF 'IBNVFLG
WRITE !," Person Class: None Active on ",$$FMTE^XLFDT(IBDT,2),!
+30 WRITE $TRANSLATE($JUSTIFY(" ",IOM)," ","-"),!
End DoDot:1
+31 QUIT
+32 ;
+33 ;/vd - IB*2.0*623 (US4055) - Beginning.
DENTAL(IBIFN) ; Select Dental Claim detail gathered and displayed here
+1 if '$GET(IBIFN)
QUIT
+2 NEW ARY,CPTMOD,I,IBLC,IBLIN,IBQ,IBRORA,IBRORARES,IBRORATX,IBX,IBXDATA,L,N,NN,NPI,NUM,POS,PRVARY,SEQ,T,T1,T2,XABCD,XIBI,XDIAG
+3 KILL ^TMP("IBXSAVE",$JOB),^TMP("IBXDISP",$JOB)
+4 SET IBLIN=$$BOX24D^IBCEF11()
+5 ;Set ^TMP("IBXDISP",$J) w/ data for Diagnosis display
SET IBX=$$BILLN^IBCEFG0(0,"1^99",IBLIN,+IBIFN,2)
+6 ;Gather procedure-level Dental data - stored in IBXDATA array
DO OUTPT^IBCEF11(IBIFN,1)
+7 ;Get the Provider Types.
DO GETPROVS(IBIFN,.PRVARY)
+8 ;Output claim-level information
+9 WRITE @IOF,"Example of dx, procedures, teeth info, and charges entered on the Dental claim"
+10 WRITE !,"--------------------------------------------------------------------------------"
+11 WRITE !,"Claim Provider:"
+12 SET IBRORA=0
+13 ; Display the Provider Types & their IDs.
IF $DATA(PRVARY)
Begin DoDot:1
+14 WRITE !
+15 SET POS=0
SET SEQ=""
+16 FOR
SET SEQ=$ORDER(PRVARY("SQ",SEQ))
if SEQ=""
QUIT
Begin DoDot:2
+17 WRITE ?POS,PRVARY("SQ",SEQ)
SET POS=POS+$LENGTH(PRVARY("SQ",SEQ))+5
End DoDot:2
End DoDot:1
+18 ;
+19 ;Output diagnosis codes using ^TMP("IBXDISP",$J) created by $$BILLN^IBCEFG0 function
+20 WRITE !!,"34a. Diagnosis:"
+21 FOR L=3,4,5
Begin DoDot:1
+22 ; Due to a request by eBiz...only 4 diagnosis codes should display on a Dental Claim (US4055).
if (L'=3)
QUIT
+23 WRITE !
+24 FOR T=3,16,29,42
Begin DoDot:2
+25 SET NUM=""
+26 IF L=3
SET NUM=$SELECT(T=3:1,T=16:2,T=29:3,T=42:4,1:"")
+27 SET T2=T+2
SET T1=T
IF NUM>9
SET T1=T-1
+28 WRITE ?T1,NUM,".",?T2,$GET(^TMP("IBXDISP",$JOB,1,IBLIN+L,T))
End DoDot:2
End DoDot:1
+29 WRITE !,"35. Dental Claim Note:"
+30 WRITE !,$$GET1^DIQ(399,IBIFN,97)
+31 ;
+32 WRITE !
DO PG
SET IBLC=13
+33 ;Order thru IBXDATA array to output procedure-level data
+34 SET ARY="TMP(""IBXDATA"",$J)"
KILL @ARY
+35 IF $DATA(IBXDATA)>1
SET N=""
FOR
SET N=$ORDER(IBXDATA(N))
if N=""
QUIT
Begin DoDot:1
+36 SET @ARY@(N,"POS")=$PIECE($GET(IBXDATA(N)),U,3)
+37 SET @ARY@(N,"CPT")=$PIECE($GET(IBXDATA(N)),U,5)
+38 SET XIBI=+$GET(IBXDATA(N,"CPLNK"))
+39 SET XDIAG=$PIECE($GET(IBXDATA(N)),U,7)
SET XABCD=""
+40 FOR I=1:1:4
IF +$PIECE(XDIAG,",",I)
IF $PIECE(XDIAG,",",I)<5
SET XABCD=XABCD_$TRANSLATE($PIECE(XDIAG,",",I),"1234,","ABCD")
+41 SET @ARY@(N,"DIAG")=XABCD
+42 SET @ARY@(N,"QTY")=$PIECE($GET(IBXDATA(N)),U,9)
+43 SET @ARY@(N,"CHARGE")=$PIECE($GET(IBXDATA(N)),U,8)*@ARY@(N,"QTY")*100
+44 SET CPTMOD=$PIECE($GET(IBXDATA(N)),U,10)
IF $TRANSLATE(CPTMOD,",")]""
FOR I=1:1:$LENGTH(CPTMOD,",")
Begin DoDot:2
+45 if $PIECE(CPTMOD,",",I)=""
QUIT
+46 SET $PIECE(CPTMOD,",",I)=$PIECE($GET(^DIC(81.3,$PIECE(CPTMOD,",",I),0)),U)
+47 SET @ARY@(N,"CPTMOD")=$TRANSLATE(CPTMOD,","," ")
End DoDot:2
+48 SET @ARY@(N,"ORALCAV")=$TRANSLATE($PIECE($GET(IBXDATA(N,"DEN")),U,1,5),U," ")
+49 ;
+50 SET @ARY@(N,"START")=$EXTRACT($PIECE($GET(IBXDATA(N)),U,1),1,2)_" "_$EXTRACT($PIECE($GET(IBXDATA(N)),U,1),3,4)_" "_$EXTRACT($PIECE($GET(IBXDATA(N)),U,1),7,8)
+51 SET @ARY@(N,"END")=$EXTRACT($PIECE($GET(IBXDATA(N)),U,2),1,2)_" "_$EXTRACT($PIECE($GET(IBXDATA(N)),U,2),3,4)_" "_$EXTRACT($PIECE($GET(IBXDATA(N)),U,2),7,8)
+52 IF $PIECE($GET(IBXDATA(N)),U,2)=""
SET @ARY@(N,"END")=@ARY@(N,"START")
+53 ;
+54 SET NN=0
FOR
SET NN=$ORDER(IBXDATA(N,"DEN1",NN))
if NN=""
QUIT
IF NN?1.N
Begin DoDot:2
+55 SET @ARY@(N,NN,"TOOTH")=$PIECE($GET(IBXDATA(N,"DEN1",NN,0)),U)
+56 SET @ARY@(N,NN,"SURFACE")=$TRANSLATE($PIECE($GET(IBXDATA(N,"DEN1",NN,0)),U,2,6),U)
End DoDot:2
End DoDot:1
+57 ;
+58 SET N=""
FOR
SET N=$ORDER(@ARY@(N))
if N=""
QUIT
Begin DoDot:1
+59 WRITE !,@ARY@(N,"START"),?9,@ARY@(N,"END"),?18,@ARY@(N,"ORALCAV")
+60 WRITE ?33,$GET(@ARY@(N,1,"TOOTH")),?36,$GET(@ARY@(N,1,"SURFACE")),?42,$GET(@ARY@(N,"CPT"))
+61 WRITE ?48,$GET(@ARY@(N,"CPTMOD")),?60,$GET(@ARY@(N,"DIAG")),?65,$GET(@ARY@(N,"QTY")),?68,$GET(@ARY@(N,"CHARGE")),?77,@ARY@(N,"POS")
+62 SET IBLC=IBLC+1
IF IBLC>20
IF ($ORDER(@ARY@(N))!($ORDER(@ARY@(N,1))))
WRITE !,$TRANSLATE($JUSTIFY("-",80)," ","-")
SET IBQ=$$PAUSE^IBCSCH1(IBLC)
if IBQ
QUIT
WRITE @IOF
DO PG
+63 SET NN=1
FOR
SET NN=$ORDER(@ARY@(N,NN))
if NN=""
QUIT
Begin DoDot:2
+64 IF $GET(@ARY@(N,NN,"TOOTH"))=""
IF ($GET(@ARY@(N,NN,"SURFACE")))=""
QUIT
+65 WRITE !,?33,$GET(@ARY@(N,NN,"TOOTH")),?36,$GET(@ARY@(N,NN,"SURFACE"))
+66 SET IBLC=IBLC+1
IF IBLC>20
IF $ORDER(@ARY@(N,NN))
WRITE !,$TRANSLATE($JUSTIFY("-",80)," ","-")
IF $TEST
SET IBQ=$$PAUSE^IBCSCH1(IBLC)
if IBQ
QUIT
WRITE @IOF
DO PG
End DoDot:2
End DoDot:1
+67 WRITE !,"--------------------------------------------------------------------------------"
+68 SET IBQ=$$PAUSE^IBCSCH1(IBLC)
+69 KILL @ARY
+70 QUIT
+71 ;
GETPROVS(IBIFN,PRVARY) ;Get the Provider Types
+1 NEW FILE,FLD,PROV,SQ,TYPE,UCTYPE
+2 KILL PRVARY
+3 if 'IBIFN
QUIT
+4 SET TYPE=""
+5 FOR
SET TYPE=$ORDER(^DGCR(399,IBIFN,"PRV","C",TYPE))
if TYPE=""
QUIT
Begin DoDot:1
+6 SET UCTYPE=$$UP^XLFSTR(TYPE)
+7 IF UCTYPE="ASSISTANT SURGEON"
SET UCTYPE="ASST SURGEON"
+8 ; Already have capitalized version of this Provider Type.
IF $DATA(PRVARY("P",UCTYPE))
QUIT
+9 SET SQ=$ORDER(^DGCR(399,IBIFN,"PRV","C",TYPE,""))
if SQ=""
QUIT
+10 SET FILE=+$PIECE($PIECE($GET(^DGCR(399,IBIFN,"PRV",SQ,0)),U,2),"(",2)
+11 SET PROV=$PIECE($PIECE($GET(^DGCR(399,IBIFN,"PRV",SQ,0)),U,2),";")
+12 SET FLD=$SELECT(FILE["355.93":41.01,1:41.99)
+13 SET NPI=$$GET1^DIQ(FILE,PROV,FLD)
if $TRANSLATE(NPI," ")=""
SET NPI="**NO NPI**"
+14 SET PRVARY("P",UCTYPE)=SQ
SET PRVARY("SQ",SQ)=UCTYPE_"/"_NPI
End DoDot:1
+15 QUIT
+16 ;
PG ; Display Dental form box numbers at top of charge list
+1 WRITE "24 25 27 28 29 29a 29b 31 38"
+2 WRITE !,"--------------------------------------------------------------------------------"
+3 SET IBLC=3
+4 QUIT
+5 ;/vd - IB*2.0*623 (US4055) - End.
+6 ;
