- 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 Jan 18, 2025@03:12:51 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 ;