IBCEP5 ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00
;;2.0;INTEGRATED BILLING;**137,232,320,348,349,377,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
EN ; -- main entry point for IBCE PRV MAINT
N IBPRV,IBINS
EN1 ; Entrypoint for non-VA provider ID maintenance hook
N IBSLEV,DIR,Y,X,IBPRMPT,IBNVAFL,IBIF
K IBFASTXT
S IBIF="" I $G(IBPRV) S IBIF=$$GET1^DIQ(355.93,IBPRV,.02,"I")
D FULL^VALM1
S IBPRMPT=$S(IBIF=1:"LAB OR FACILITY",1:"PROVIDER")
S DIR(0)="SA^1:"_IBPRMPT_"'S OWN IDS;2:"_IBPRMPT_" IDS FURNISHED BY AN INSURANCE COMPANY"
S DIR("A")="SELECT SOURCE OF ID: ",DIR("B")=$P($P(DIR(0),":",2),";")
W ! D ^DIR K DIR W !
I Y'>0 Q
S IBSLEV=+Y
D EN^VALM("IBCE PRVPRV MAINT")
Q
;
HDR ; -- header code
N IBC,Z,IBIF
S IBIF="" I $G(IBNPRV) S IBIF=$$GET1^DIQ(355.93,IBNPRV,.02,"I")
K VALMHDR
S IBC=1
S IBPRMPT=$S(IBIF=1:"Lab or Facility",1:"Performing Provider")
S Z="** "_$S($G(IBSLEV)=1:IBPRMPT_"'s Own IDs (No Specific Insurance Co)",1:IBPRMPT_" IDs from Insurance Co")_" **"
S VALMHDR(IBC)=$J("",80-$L(Z)\2)_Z,IBC=IBC+1
I $G(IBPRV),'+IBIF S VALMHDR(IBC)="PROVIDER : "_$$EXPAND^IBTRE(355.9,.01,IBPRV)_$S(IBPRV["VA(200":" (VA PROVIDER)",1:" (NON-VA PROVIDER)"),IBC=IBC+1
I $G(IBPRV),+IBIF S VALMHDR(IBC)="Provider: "_$$EXPAND^IBTRE(355.9,.01,IBPRV)_$S(IBIF=1:"(Non-VA Lab or Facility)",1:""),IBC=IBC+1
I $G(IBINS) D
. N PCF,PCDISP
. S PCF=$P($G(^DIC(36,+IBINS,3)),"^",13)
. S PCDISP=$S($G(IBSLEV)'=2!($G(IBPRV)'["VA(200,"):"",PCF="C":"(Child)",PCF="P":"(Parent)",1:"")
. S VALMHDR(IBC)=$S(IBIF:"Insurance Co: ",1:"INSURANCE CO: ")_$P($G(^DIC(36,+IBINS,0)),U)_" "_PCDISP
Q
;
INIT ; -- init variables and list array
N IBFILE,DIR,DIC,Y,X,DTOUT,DUOUT,IBIF,AGAIN
;
K ^TMP("IB_EDITED_IDS",$J) ; This will be to keep track of ID's edited during this session
S IBIF="" I $G(IBNPRV) S IBIF=$$GET1^DIQ(355.93,IBNPRV,.02,"I")
;
; Removing Care Unit under certain conditions
; This list is used for multiple purposes and not all have Care Units Associated with them
; Also, a different protocol menu is used with these
; IBNPRV is a non VA provider
; IBIF = 1 means this is a group or facility, not an individual.
;
I $G(IBNPRV),$G(IBIF)=1 D
. S VALM("TITLE")="Secondary Provider ID"
. K VALMDDF("CAREUNIT")
. I VALMCAP["Care Unit" S VALMCAP=$P(VALMCAP,"Care Unit")_" "_$P(VALMCAP,"Care Unit",2)
. K VALM("PROTOCOL")
. S Y=$$FIND1^DIC(101,,,"IBCE PRVNVA LOF MAINT")
. I Y S VALM("PROTOCOL")=+Y_";ORD(101,"
;
I $G(IBPRV) S IBFILE="IBA(355.93,",IBPRV=+IBPRV_";"_IBFILE
I '$G(IBPRV) D G:$G(VALMQUIT) INITQ
. S DIR(0)="SAO^V:VA PROVIDER;N:NON-VA PROVIDER",DIR("A")="(V)A or (N)on-VA provider: ",DIR("B")="V"
. D ^DIR K DIR
. I "NV"'[Y!(Y="") S VALMQUIT=1 Q
. S IBFILE=$S(Y="V":"VA(200,",1:"IBA(355.93,")
. S DIC=U_IBFILE,DIC(0)="AEMQ"_$S(IBFILE["355.93":"L",1:"")
. S DIC("A")="Select "_$S(IBFILE["355.93":"NON-",1:"")_"V.A. PROVIDER NAME: "
. S:IBFILE["355.93" DIC("DR")=".02////2;.03;.04"
. F D I $G(IBPRV)!$G(VALMQUIT) K DIC Q
.. D ^DIC
.. I $D(DTOUT)!$D(DUOUT) S VALMQUIT=1 Q
.. I Y'>0 W !,*7,"This is a required response. Enter '^' to exit" Q
.. S IBPRV=+Y_";"_IBFILE
;
AGAIN I $G(IBSLEV)=2 D G:$G(AGAIN) AGAIN G:$G(VALMQUIT) INITQ
. S AGAIN=0
. S DIR(0)="PA^DIC(36,:AEMQ",DIR("A")="Select INSURANCE CO: ",DIR("?",1)="Select an INSURANCE CO to display its provider ID's"
. D ^DIR K DIR
. I $D(DTOUT)!$D(DUOUT) S VALMQUIT=1 Q
. S IBINS=$S(Y>0:+Y,1:"NO")
. I $G(IBPRV)'["VA(200," Q ; Only VA providers
. I $P($G(^DIC(36,+IBINS,3)),"^",13)="C" D S AGAIN=1 Q
.. W !,*7,"This is a Child Insurance Company. Editing IDs is not permitted."
;
E D
. S IBINS="NO"
D BLD
INITQ Q
;
BLD ; Build initial display
; Assumes IBPRV = the variable ptr for prov id file (355.9)
; IBINS = the ien of the ins co or if null, ALL is assumed
; IBSLEV = 1 to display only provider default ids
; = 2 to display all provider/insurance co ids
N IB,IBLCT,IBCT,CT,PT,CU,INS,FT,Z,IBENT,IB1,IBIF,FORM,CAREUNT,CARETYP ;JRA IB*2.0*592 Added: FORM,CAREUNT,CARETYP
;
S IBIF="" I $G(IBPRV)[355.93 S IBIF=$$GET1^DIQ(355.93,+IBPRV,.02,"I")
;
K ^TMP("IBPRV_",$J),^TMP("IBPRV_SORT",$J)
K Z0
S (IBENT,IBCT,IBLCT)=0,INS="",IB1=1
F S INS=$S($G(IBINS):IBINS,IBSLEV=1:"*ALL*",1:$O(^IBA(355.9,"AUNIQ",IBPRV,INS))) Q:$S(INS="":1,$G(IBINS)!(IBSLEV=1):$D(CU),1:0) S CU="",IB1=0 F S CU=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU)) Q:CU="" D
. S FT="" F S FT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT)) Q:FT="" S CT="" F S CT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT)) Q:CT="" S PT=0 F S PT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT,PT)) Q:'PT D
.. S Z=0 F S Z=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT,PT,Z)) Q:'Z S IB=$G(^IBA(355.9,Z,0)) D
... S ^TMP("IBPRV_SORT",$J,$S(INS:$P($G(^DIC(36,+INS,0)),U)_" ",1:" ALL"),PT,FT,CT,CU,Z)=$P(IB,U,7)
;
I IBSLEV=1,IBPRV["IBA(355.93",$P($G(^IBA(355.93,+IBPRV,0)),U,12)'="" S ^TMP("IBPRV_SORT",$J," ALL",+$$STLIC^IBCEP8(),0,0,"*N/A*",0)=$P(^IBA(355.93,+IBPRV,0),U,12)
S INS="" F S INS=$O(^TMP("IBPRV_SORT",$J,INS)) Q:INS="" D
. I '$G(IBINS),'IBIF D:IBLCT SET^VALM10(IBLCT+1," ",IBCT) S IBLCT=$S(IBLCT:IBLCT+2,1:1) D SET^VALM10(IBLCT,"INSURANCE CO: "_$S($E(INS)=" ":"ALL INSURANCE",1:INS),$S(IBCT:IBCT,1:1))
. S PT=""
. F S PT=$O(^TMP("IBPRV_SORT",$J,INS,PT)) Q:PT="" S FT="" F S FT=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT)) Q:FT="" S CT="" F S CT=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT)) Q:CT="" D
.. S CU="" F S CU=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT,CU)) Q:CU="" S Z="" F S Z=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT,CU,Z)) Q:Z="" S IB=$G(^(Z)) D
... S IBLCT=IBLCT+1,IBCT=IBCT+1
... ;JRA IB*2.0*592 Modify to accommodate Dental Form 7 (FT=4)
... ;S Z0=$E(IBCT_" ",1,4)_" "_$E($$EXPAND^IBTRE(355.9,.06,PT)_$S(PT=$$STLIC^IBCEP8():"("_$P($G(^DIC(5,+$P($G(^IBA(355.93,+IBPRV,0)),U,7),0)),U,2)_")",1:"")_$J("",20),1,20)_" "_$S(FT=1:"UB-04",FT=2:"1500 ",1:"BOTH ") ;JRA IB*2.0*592 ';'
... S FORM=$S(FT=1:"UB-04",FT=2:"1500",1:"BOTH")
... S Z0=$E(IBCT_" ",1,4)_" "_$E($$EXPAND^IBTRE(355.9,.06,PT)_$S(PT=$$STLIC^IBCEP8():"("_$P($G(^DIC(5,+$P($G(^IBA(355.93,+IBPRV,0)),U,7),0)),U,2)_")",1:"")_$J("",20),1,20)_" "_FORM ;JRA IB*2.0*592
... ;S Z0=Z0_" "_$E($S(CT=3:"RX",CT=1:"INPT",CT=2:"OUTPT",1:"INPT/OUTPT")_$J("",11),1,11) ;JRA IB*2.0*592 ';'
... S CARETYP=$E($S(CT=3:"RX",CT=1:"INPT",CT=2:"OUTPT",1:"INPT/OUTPT"),1,10) ;JRA IB*2.0*592
... S Z0=Z0_$J("",11-$L(FORM))_CARETYP ;JRA IB*2.0*592
... ;S Z0=Z0_" "_$E($S(CU'="*N/A*":$P($G(^IBA(355.95,+$G(^IBA(355.96,CU,0)),0)),U),1:"")_$J("",15),1,15)_"|" I Z0["MEDICINE" X "*" ;JRA IB*2.0*592 ';'
... S CAREUNT=$E($S(CU'="*N/A*":$P($G(^IBA(355.95,+$G(^IBA(355.96,CU,0)),0)),U),1:""),1,12) ;JRA IB*2.0*592
... S CAREUNT=CAREUNT_$J("",12-$L(CAREUNT)+1) ;JRA IB*2.0*592
... S Z0=Z0_($J("",(12-$L(CARETYP)+1))) ;JRA IB*2.0*592
... S Z0=Z0_CAREUNT ;JRA IB*2.0*592
... ;D SET^VALM10(IBLCT,Z0_" "_IB,IBCT) ;JRA IB*2.0*592 ';'
... ;IA# 10117;IB*2.0*592
... D SET^VALM10(IBLCT,Z0_IB,IBCT) ;JRA IB*2.0*592
... S ^TMP("IBPRV_",$J,"ZIDX",IBCT)=$S(Z'=0:Z,1:"LIC^"_IBPRV)
I IBSLEV=1,IBPRV["VA(200" D
. N IBP
. S IBP=+IBPRV
. Q:'$$GETLIC^IBCEP5D(.IBP)
. I IBCT S IBLCT=IBLCT+1 D SET^VALM10(IBLCT," ",IBCT)
. S Z=0 F S Z=$O(IBP(Z)) Q:'Z D
.. S IBLCT=IBLCT+1,IBCT=IBCT+1
.. D SET^VALM10(IBLCT,$E(IBCT_" ",1,4)_$E($P($G(^DIC(5,+Z,0)),U,2)_" STATE LICENSE #"_$J("",20),1,20)_$J("",39)_IBP(Z),IBCT)
.. S ^TMP("IBPRV_",$J,"ZIDX",IBCT)="LIC^"_+IBPRV
K ^TMP("IBPRV_SORT",$J)
;
I IBLCT=0 D G BLDQ ; No entries for ins co selected
. D SET^VALM10(1," ")
. D SET^VALM10(2," No ID's found for provider "_$S('$G(IBINS):"",1:"and selected insurance co"))
. S IBLCT=2
;
BLDQ K VALMCNT,VALMBG
S VALMCNT=IBLCT,VALMBG=1
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
D COPYPROV^IBCEP5A(IBINS)
K IBPRV
D CLEAN^VALM10
K ^TMP("IBPRV_",$J),^TMP("IBPRV_SORT",$J),IBINS,IBALL
Q
;
EXPND ; -- expand code
Q
;
SEL(IBDA,MANY) ; Select from provider id list
; IBDA is passed by reference and IBDA(1) returned containing
; ien's of the provider id records selected (file 355.9).
; If > 1 entry can be selected, MANY is set to 1
N Z
S IBDA=0
D EN^VALM2($G(XQORNOD(0)),$S($G(MANY):"",1:"S"))
S Z=0 F S Z=$O(VALMY(Z)) Q:'Z S IBDA=IBDA+1,IBDA(IBDA)=$G(^TMP("IBPRV_",$J,"ZIDX",Z))
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEP5 8536 printed Dec 13, 2024@02:11:38 Page 2
IBCEP5 ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00
+1 ;;2.0;INTEGRATED BILLING;**137,232,320,348,349,377,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; -- main entry point for IBCE PRV MAINT
+1 NEW IBPRV,IBINS
EN1 ; Entrypoint for non-VA provider ID maintenance hook
+1 NEW IBSLEV,DIR,Y,X,IBPRMPT,IBNVAFL,IBIF
+2 KILL IBFASTXT
+3 SET IBIF=""
IF $GET(IBPRV)
SET IBIF=$$GET1^DIQ(355.93,IBPRV,.02,"I")
+4 DO FULL^VALM1
+5 SET IBPRMPT=$SELECT(IBIF=1:"LAB OR FACILITY",1:"PROVIDER")
+6 SET DIR(0)="SA^1:"_IBPRMPT_"'S OWN IDS;2:"_IBPRMPT_" IDS FURNISHED BY AN INSURANCE COMPANY"
+7 SET DIR("A")="SELECT SOURCE OF ID: "
SET DIR("B")=$PIECE($PIECE(DIR(0),":",2),";")
+8 WRITE !
DO ^DIR
KILL DIR
WRITE !
+9 IF Y'>0
QUIT
+10 SET IBSLEV=+Y
+11 DO EN^VALM("IBCE PRVPRV MAINT")
+12 QUIT
+13 ;
HDR ; -- header code
+1 NEW IBC,Z,IBIF
+2 SET IBIF=""
IF $GET(IBNPRV)
SET IBIF=$$GET1^DIQ(355.93,IBNPRV,.02,"I")
+3 KILL VALMHDR
+4 SET IBC=1
+5 SET IBPRMPT=$SELECT(IBIF=1:"Lab or Facility",1:"Performing Provider")
+6 SET Z="** "_$SELECT($GET(IBSLEV)=1:IBPRMPT_"'s Own IDs (No Specific Insurance Co)",1:IBPRMPT_" IDs from Insurance Co")_" **"
+7 SET VALMHDR(IBC)=$JUSTIFY("",80-$LENGTH(Z)\2)_Z
SET IBC=IBC+1
+8 IF $GET(IBPRV)
IF '+IBIF
SET VALMHDR(IBC)="PROVIDER : "_$$EXPAND^IBTRE(355.9,.01,IBPRV)_$SELECT(IBPRV["VA(200":" (VA PROVIDER)",1:" (NON-VA PROVIDER)")
SET IBC=IBC+1
+9 IF $GET(IBPRV)
IF +IBIF
SET VALMHDR(IBC)="Provider: "_$$EXPAND^IBTRE(355.9,.01,IBPRV)_$SELECT(IBIF=1:"(Non-VA Lab or Facility)",1:"")
SET IBC=IBC+1
+10 IF $GET(IBINS)
Begin DoDot:1
+11 NEW PCF,PCDISP
+12 SET PCF=$PIECE($GET(^DIC(36,+IBINS,3)),"^",13)
+13 SET PCDISP=$SELECT($GET(IBSLEV)'=2!($GET(IBPRV)'["VA(200,"):"",PCF="C":"(Child)",PCF="P":"(Parent)",1:"")
+14 SET VALMHDR(IBC)=$SELECT(IBIF:"Insurance Co: ",1:"INSURANCE CO: ")_$PIECE($GET(^DIC(36,+IBINS,0)),U)_" "_PCDISP
End DoDot:1
+15 QUIT
+16 ;
INIT ; -- init variables and list array
+1 NEW IBFILE,DIR,DIC,Y,X,DTOUT,DUOUT,IBIF,AGAIN
+2 ;
+3 ; This will be to keep track of ID's edited during this session
KILL ^TMP("IB_EDITED_IDS",$JOB)
+4 SET IBIF=""
IF $GET(IBNPRV)
SET IBIF=$$GET1^DIQ(355.93,IBNPRV,.02,"I")
+5 ;
+6 ; Removing Care Unit under certain conditions
+7 ; This list is used for multiple purposes and not all have Care Units Associated with them
+8 ; Also, a different protocol menu is used with these
+9 ; IBNPRV is a non VA provider
+10 ; IBIF = 1 means this is a group or facility, not an individual.
+11 ;
+12 IF $GET(IBNPRV)
IF $GET(IBIF)=1
Begin DoDot:1
+13 SET VALM("TITLE")="Secondary Provider ID"
+14 KILL VALMDDF("CAREUNIT")
+15 IF VALMCAP["Care Unit"
SET VALMCAP=$PIECE(VALMCAP,"Care Unit")_" "_$PIECE(VALMCAP,"Care Unit",2)
+16 KILL VALM("PROTOCOL")
+17 SET Y=$$FIND1^DIC(101,,,"IBCE PRVNVA LOF MAINT")
+18 IF Y
SET VALM("PROTOCOL")=+Y_";ORD(101,"
End DoDot:1
+19 ;
+20 IF $GET(IBPRV)
SET IBFILE="IBA(355.93,"
SET IBPRV=+IBPRV_";"_IBFILE
+21 IF '$GET(IBPRV)
Begin DoDot:1
+22 SET DIR(0)="SAO^V:VA PROVIDER;N:NON-VA PROVIDER"
SET DIR("A")="(V)A or (N)on-VA provider: "
SET DIR("B")="V"
+23 DO ^DIR
KILL DIR
+24 IF "NV"'[Y!(Y="")
SET VALMQUIT=1
QUIT
+25 SET IBFILE=$SELECT(Y="V":"VA(200,",1:"IBA(355.93,")
+26 SET DIC=U_IBFILE
SET DIC(0)="AEMQ"_$SELECT(IBFILE["355.93":"L",1:"")
+27 SET DIC("A")="Select "_$SELECT(IBFILE["355.93":"NON-",1:"")_"V.A. PROVIDER NAME: "
+28 if IBFILE["355.93"
SET DIC("DR")=".02////2;.03;.04"
+29 FOR
Begin DoDot:2
+30 DO ^DIC
+31 IF $DATA(DTOUT)!$DATA(DUOUT)
SET VALMQUIT=1
QUIT
+32 IF Y'>0
WRITE !,*7,"This is a required response. Enter '^' to exit"
QUIT
+33 SET IBPRV=+Y_";"_IBFILE
End DoDot:2
IF $GET(IBPRV)!$GET(VALMQUIT)
KILL DIC
QUIT
End DoDot:1
if $GET(VALMQUIT)
GOTO INITQ
+34 ;
AGAIN IF $GET(IBSLEV)=2
Begin DoDot:1
+1 SET AGAIN=0
+2 SET DIR(0)="PA^DIC(36,:AEMQ"
SET DIR("A")="Select INSURANCE CO: "
SET DIR("?",1)="Select an INSURANCE CO to display its provider ID's"
+3 DO ^DIR
KILL DIR
+4 IF $DATA(DTOUT)!$DATA(DUOUT)
SET VALMQUIT=1
QUIT
+5 SET IBINS=$SELECT(Y>0:+Y,1:"NO")
+6 ; Only VA providers
IF $GET(IBPRV)'["VA(200,"
QUIT
+7 IF $PIECE($GET(^DIC(36,+IBINS,3)),"^",13)="C"
Begin DoDot:2
+8 WRITE !,*7,"This is a Child Insurance Company. Editing IDs is not permitted."
End DoDot:2
SET AGAIN=1
QUIT
End DoDot:1
if $GET(AGAIN)
GOTO AGAIN
if $GET(VALMQUIT)
GOTO INITQ
+9 ;
+10 IF '$TEST
Begin DoDot:1
+11 SET IBINS="NO"
End DoDot:1
+12 DO BLD
INITQ QUIT
+1 ;
BLD ; Build initial display
+1 ; Assumes IBPRV = the variable ptr for prov id file (355.9)
+2 ; IBINS = the ien of the ins co or if null, ALL is assumed
+3 ; IBSLEV = 1 to display only provider default ids
+4 ; = 2 to display all provider/insurance co ids
+5 ;JRA IB*2.0*592 Added: FORM,CAREUNT,CARETYP
NEW IB,IBLCT,IBCT,CT,PT,CU,INS,FT,Z,IBENT,IB1,IBIF,FORM,CAREUNT,CARETYP
+6 ;
+7 SET IBIF=""
IF $GET(IBPRV)[355.93
SET IBIF=$$GET1^DIQ(355.93,+IBPRV,.02,"I")
+8 ;
+9 KILL ^TMP("IBPRV_",$JOB),^TMP("IBPRV_SORT",$JOB)
+10 KILL Z0
+11 SET (IBENT,IBCT,IBLCT)=0
SET INS=""
SET IB1=1
+12 FOR
SET INS=$SELECT($GET(IBINS):IBINS,IBSLEV=1:"*ALL*",1:$ORDER(^IBA(355.9,"AUNIQ",IBPRV,INS)))
if $SELECT(INS=""
QUIT
SET CU=""
SET IB1=0
FOR
SET CU=$ORDER(^IBA(355.9,"AUNIQ",IBPRV,INS,CU))
if CU=""
QUIT
Begin DoDot:1
+13 SET FT=""
FOR
SET FT=$ORDER(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT))
if FT=""
QUIT
SET CT=""
FOR
SET CT=$ORDER(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT))
if CT=""
QUIT
SET PT=0
FOR
SET PT=$ORDER(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT,PT))
if 'PT
QUIT
Begin DoDot:2
+14 SET Z=0
FOR
SET Z=$ORDER(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT,PT,Z))
if 'Z
QUIT
SET IB=$GET(^IBA(355.9,Z,0))
Begin DoDot:3
+15 SET ^TMP("IBPRV_SORT",$JOB,$SELECT(INS:$PIECE($GET(^DIC(36,+INS,0)),U)_" ",1:" ALL"),PT,FT,CT,CU,Z)=$PIECE(IB,U,7)
End DoDot:3
End DoDot:2
End DoDot:1
+16 ;
+17 IF IBSLEV=1
IF IBPRV["IBA(355.93"
IF $PIECE($GET(^IBA(355.93,+IBPRV,0)),U,12)'=""
SET ^TMP("IBPRV_SORT",$JOB," ALL",+$$STLIC^IBCEP8(),0,0,"*N/A*",0)=$PIECE(^IBA(355.93,+IBPRV,0),U,12)
+18 SET INS=""
FOR
SET INS=$ORDER(^TMP("IBPRV_SORT",$JOB,INS))
if INS=""
QUIT
Begin DoDot:1
+19 IF '$GET(IBINS)
IF 'IBIF
if IBLCT
DO SET^VALM10(IBLCT+1," ",IBCT)
SET IBLCT=$SELECT(IBLCT:IBLCT+2,1:1)
DO SET^VALM10(IBLCT,"INSURANCE CO: "_$SELECT($EXTRACT(INS)=" ":"ALL INSURANCE",1:INS),$SELECT(IBCT:IBCT,1:1))
+20 SET PT=""
+21 FOR
SET PT=$ORDER(^TMP("IBPRV_SORT",$JOB,INS,PT))
if PT=""
QUIT
SET FT=""
FOR
SET FT=$ORDER(^TMP("IBPRV_SORT",$JOB,INS,PT,FT))
if FT=""
QUIT
SET CT=""
FOR
SET CT=$ORDER(^TMP("IBPRV_SORT",$JOB,INS,PT,FT,CT))
if CT=""
QUIT
Begin DoDot:2
+22 SET CU=""
FOR
SET CU=$ORDER(^TMP("IBPRV_SORT",$JOB,INS,PT,FT,CT,CU))
if CU=""
QUIT
SET Z=""
FOR
SET Z=$ORDER(^TMP("IBPRV_SORT",$JOB,INS,PT,FT,CT,CU,Z))
if Z=""
QUIT
SET IB=$GET(^(Z))
Begin DoDot:3
+23 SET IBLCT=IBLCT+1
SET IBCT=IBCT+1
+24 ;JRA IB*2.0*592 Modify to accommodate Dental Form 7 (FT=4)
+25 ;S Z0=$E(IBCT_" ",1,4)_" "_$E($$EXPAND^IBTRE(355.9,.06,PT)_$S(PT=$$STLIC^IBCEP8():"("_$P($G(^DIC(5,+$P($G(^IBA(355.93,+IBPRV,0)),U,7),0)),U,2)_")",1:"")_$J("",20),1,20)_" "_$S(FT=1:"UB-04",FT=2:"1500 ",1:"BOTH ") ;JRA IB*2.0*592 ';'
+26 SET FORM=$SELECT(FT=1:"UB-04",FT=2:"1500",1:"BOTH")
+27 ;JRA IB*2.0*592
SET Z0=$EXTRACT(IBCT_" ",1,4)_" "_$EXTRACT($$EXPAND^IBTRE(355.9,.06,PT)_$SELECT(PT=$$STLIC^IBCEP8():"("_$PIECE($GET(^DIC(5,+$PIECE($GET(^IBA(355.93,+IBPRV,0)),U,7),0)),U,2)_")",1:"")_$JUSTIFY("",20),1,20)
_" "_FORM
+28 ;S Z0=Z0_" "_$E($S(CT=3:"RX",CT=1:"INPT",CT=2:"OUTPT",1:"INPT/OUTPT")_$J("",11),1,11) ;JRA IB*2.0*592 ';'
+29 ;JRA IB*2.0*592
SET CARETYP=$EXTRACT($SELECT(CT=3:"RX",CT=1:"INPT",CT=2:"OUTPT",1:"INPT/OUTPT"),1,10)
+30 ;JRA IB*2.0*592
SET Z0=Z0_$JUSTIFY("",11-$LENGTH(FORM))_CARETYP
+31 ;S Z0=Z0_" "_$E($S(CU'="*N/A*":$P($G(^IBA(355.95,+$G(^IBA(355.96,CU,0)),0)),U),1:"")_$J("",15),1,15)_"|" I Z0["MEDICINE" X "*" ;JRA IB*2.0*592 ';'
+32 ;JRA IB*2.0*592
SET CAREUNT=$EXTRACT($SELECT(CU'="*N/A*":$PIECE($GET(^IBA(355.95,+$GET(^IBA(355.96,CU,0)),0)),U),1:""),1,12)
+33 ;JRA IB*2.0*592
SET CAREUNT=CAREUNT_$JUSTIFY("",12-$LENGTH(CAREUNT)+1)
+34 ;JRA IB*2.0*592
SET Z0=Z0_($JUSTIFY("",(12-$LENGTH(CARETYP)+1)))
+35 ;JRA IB*2.0*592
SET Z0=Z0_CAREUNT
+36 ;D SET^VALM10(IBLCT,Z0_" "_IB,IBCT) ;JRA IB*2.0*592 ';'
+37 ;IA# 10117;IB*2.0*592
+38 ;JRA IB*2.0*592
DO SET^VALM10(IBLCT,Z0_IB,IBCT)
+39 SET ^TMP("IBPRV_",$JOB,"ZIDX",IBCT)=$SELECT(Z'=0:Z,1:"LIC^"_IBPRV)
End DoDot:3
End DoDot:2
End DoDot:1
+40 IF IBSLEV=1
IF IBPRV["VA(200"
Begin DoDot:1
+41 NEW IBP
+42 SET IBP=+IBPRV
+43 if '$$GETLIC^IBCEP5D(.IBP)
QUIT
+44 IF IBCT
SET IBLCT=IBLCT+1
DO SET^VALM10(IBLCT," ",IBCT)
+45 SET Z=0
FOR
SET Z=$ORDER(IBP(Z))
if 'Z
QUIT
Begin DoDot:2
+46 SET IBLCT=IBLCT+1
SET IBCT=IBCT+1
+47 DO SET^VALM10(IBLCT,$EXTRACT(IBCT_" ",1,4)_$EXTRACT($PIECE($GET(^DIC(5,+Z,0)),U,2)_" STATE LICENSE #"_$JUSTIFY("",20),1,20)_$JUSTIFY("",39)_IBP(Z),IBCT)
+48 SET ^TMP("IBPRV_",$JOB,"ZIDX",IBCT)="LIC^"_+IBPRV
End DoDot:2
End DoDot:1
+49 KILL ^TMP("IBPRV_SORT",$JOB)
+50 ;
+51 ; No entries for ins co selected
IF IBLCT=0
Begin DoDot:1
+52 DO SET^VALM10(1," ")
+53 DO SET^VALM10(2," No ID's found for provider "_$SELECT('$GET(IBINS):"",1:"and selected insurance co"))
+54 SET IBLCT=2
End DoDot:1
GOTO BLDQ
+55 ;
BLDQ KILL VALMCNT,VALMBG
+1 SET VALMCNT=IBLCT
SET VALMBG=1
+2 QUIT
+3 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 DO COPYPROV^IBCEP5A(IBINS)
+2 KILL IBPRV
+3 DO CLEAN^VALM10
+4 KILL ^TMP("IBPRV_",$JOB),^TMP("IBPRV_SORT",$JOB),IBINS,IBALL
+5 QUIT
+6 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
SEL(IBDA,MANY) ; Select from provider id list
+1 ; IBDA is passed by reference and IBDA(1) returned containing
+2 ; ien's of the provider id records selected (file 355.9).
+3 ; If > 1 entry can be selected, MANY is set to 1
+4 NEW Z
+5 SET IBDA=0
+6 DO EN^VALM2($GET(XQORNOD(0)),$SELECT($GET(MANY):"",1:"S"))
+7 SET Z=0
FOR
SET Z=$ORDER(VALMY(Z))
if 'Z
QUIT
SET IBDA=IBDA+1
SET IBDA(IBDA)=$GET(^TMP("IBPRV_",$JOB,"ZIDX",Z))
+8 QUIT
+9 ;
