IBCEP0 ;ALB/TMP - Functions for PROVIDER ID MAINTENANCE ;13-DEC-99
;;2.0;INTEGRATED BILLING;**137,191,239,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 INS ID
N IBINS,IBDSP,IBSORT,IBPRV ; Variables should be available throughout actions
K IBFASTXT
D FULL^VALM1
D EN^VALM("IBCE PRVINS ID")
Q
;
EN1(IBINS) ; Entrypoint from insurance co maintenance
N IBDSP,IBSORT ; Variables should be available throughout actions
D FULL^VALM1
D EN^VALM("IBCE PRVINS ID FROM INS MAINT")
Q
;
HDR ; -- header code
N Z,Z0,Z1,IBCT,IBPPTYP,IBEMCTYP
S IBCT=1
K VALMHDR
I $G(IBINS) D
. N PCF,PCDISP
. S PCF=$P($G(^DIC(36,+IBINS,3)),U,13)
. S PCDISP=$S(PCF="C":"(Child)",PCF="P":"(Parent)",1:"")
. S VALMHDR(1)="Insurance Co: "_$P($G(^DIC(36,+IBINS,0)),U)_" "_PCDISP
. ; Get performing provider id type for insurance co
. S IBPPTYP=$$PPTYP(IBINS)
. ; Get ien of EMC ID from file 355.97
. S IBEMCTYP=+$$EMCID^IBCEP()
. I $G(IBSORT)="ALL"!($G(IBDSP)="I")!($G(IBSORT)=IBPPTYP)!($G(IBSORT)=IBEMCTYP) D
.. ; Look for care unit in either of these id types - if there, report on line 2 of header
.. I $G(IBSORT)=IBPPTYP S IBEMCTYP=0
.. I $G(IBSORT)=IBEMCTYP S IBPPTYP=0
.. F Z0=IBPPTYP_"P",IBEMCTYP_"E" S Z1="" F S Z1=$O(^IBA(355.96,"D",+IBINS,+Z0,Z1)) Q:Z1="" I Z1'="*N/A*" S Z($E(Z0,$L(Z0)))=1 Q
.. I $D(Z("P"))!$D(Z("E")) D
... S IBCT=IBCT+1
... S VALMHDR(IBCT)=" "_$S($D(Z("P")):"PERFORMING PROV ID"_$S($D(Z("E")):" AND ",1:""),1:"")_$S($D(Z("E")):"EMC PROV ID",1:"")_" MAY REQUIRE CARE UNIT"
. I $D(Z("P"))!$D(Z("E")) S IBCT=IBCT+1,VALMHDR(IBCT)=" "
. S IBCT=IBCT+1,VALMHDR(IBCT)=" PROVIDER "_$S($G(IBDSP)="I":"ID TYPE",1:"NAME ")_$J("",6)_"FORM CARE TYPE CARE UNIT ID#"
Q
;
INIT ; Initialization
K ^TMP("IB_EDITED_IDS",$J) ; This will be to keep track of ID's edited during this session
D INSID(.IBINS,.IBDSP,.IBSORT)
I $G(IBDSP)="I",$G(IBSORT) S IBPRV=IBSORT
I '$G(IBINS) S VALMQUIT=1
Q
;
INSID(IBINS,IBDSP,IBSORT) ;
N DIC,DIR,DA,X,Y,IBOK,DTOUT,DUOUT
S IBOK=1
I '$G(IBINS) D
. S DIC(0)="AEMQ",DIC="^DIC(36," D ^DIC
. I Y'>0 S IBOK=0 Q
. S IBINS=+Y
I '$G(IBINS) S IBOK=0
I 'IBOK G INSIDQ
;
S DIR(0)="SA^D:INSURANCE CO DEFAULT IDS;I:INDIVIDUAL PROVIDER IDS FURNISHED BY THE INS CO;A:ALL IDS FURNISHED BY THE INS CO BY PROVIDER TYPE"
S DIR("A")="SELECT DISPLAY CONTENT: ",DIR("B")="A"
S DIR("?",1)="(D) DISPLAY CONTAINS ONLY THOSE IDS ASSIGNED AS DEFAULTS TO THE FACILITY BY",DIR("?",2)=" THE INSURANCE COMPANY"
S DIR("?",3)="(I) DISPLAY CONTAINS ONLY THOSE IDS ASSIGNED TO INDIVIDUAL PROVIDERS BY THE",DIR("?",4)=" INSURANCE COMPANY"
S DIR("?",5)="(A) DISPLAY CONTAINS ALL IDS ASSIGNED BY THE INSURANCE COMPANY FOR ONE OR ALL",DIR("?")=" PROVIDER ID TYPES"
W ! D ^DIR K DIR W !
I $D(DTOUT)!$D(DUOUT)!("DIA"'[Y) S IBOK=0 G INSIDQ
S IBDSP=Y,IBSORT=""
I IBDSP="A"!(IBDSP="I") F D Q:'IBOK!(IBSORT'="")
. ;
. I IBDSP="A" D
.. S DIR("A")="Display only IDs with a specific ID Qualifier?: "
.. S DIR("?",1)="Answer Yes to select a specific ID Qualifier by which to display IDs."
.. S DIR("?")="Answer No to display all IDs."
.. Q
. ;
. I IBDSP="I" D
.. S DIR("A")="Display IDs for a specific Provider?: "
.. S DIR("?",1)="Answer Yes to select a specific Provider."
.. S DIR("?")="Answer No to display all Providers."
.. Q
. ;
. S DIR("B")="NO",DIR(0)="YA"
. W ! D ^DIR K DIR W !
. I $D(DTOUT)!$D(DUOUT) S IBOK=0 Q
. I Y'=1 S IBSORT="ALL" Q
. ;
. I IBDSP="A" D Q
.. S DIC(0)="AEMQ",DIC="^IBE(355.97,",DIC("S")="I $S('$P(^(0),U,2):1,1:$P(^(0),U,2)=3)"
.. S DIC("A")="Select type of ID Qualifier: "
.. D ^DIC K DIC
.. I Y>0 S IBSORT=+Y Q
.. I $D(DTOUT)!$D(DUOUT) S IBOK=0
. ;
. I IBDSP="I" D Q
.. N DA
.. S DIR(0)="399.0222,.02A",DIR("A")="SELECT PROVIDER: "
.. W ! D ^DIR K DIR W !
.. I Y>0 S IBSORT=Y Q
.. I $D(DTOUT)!$D(DUOUT) S IBOK=0 Q
. S IBOK=0 Q
;
G:'IBOK INSIDQ
D BLD(IBINS,IBDSP,IBSORT)
INSIDQ I 'IBOK S VALMQUIT=1
Q
;
BLD(IBINS,IBDSP,IBSORT) ; Build display for Insurance co level provider ID's
N IB,IBENT,IBLCT,IBCT,IBPRV,IBSRT1,IBSRT2,IBOSRT1,IBOSRT2,CU,FT,PT,CT,Z,Z0
K ^TMP("IBPRV_INS_ID",$J),^TMP("IBPRV_INS_SORT",$J)
;
S (IBENT,IBCT,IBLCT)=0
;
I "DA"[$G(IBDSP) D
. S CU="" F S CU=$O(^IBA(355.91,"AUNIQ",IBINS,CU)) Q:CU="" S FT="" F S FT=$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT)) Q:FT="" D
.. S CT="" F S CT=$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT)) Q:CT="" S PT=0 F S PT=$S(IBDSP="A"&IBSORT:IBSORT,1:$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT,PT))) Q:'PT D Q:IBDSP="A"&IBSORT
... S Z=0 F S Z=$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT,PT,Z)) Q:'Z S IB=$G(^IBA(355.91,Z,0)) S ^TMP("IBPRV_INS_SORT",$J,PT,"^<<INS CO DEFAULT>>",FT,CT,CU,Z)=$P(IB,U,7)_U
;
I "IA"[$G(IBDSP) D
. S IBPRV=""
. N IB1,IB2
. F S IBPRV=$O(^IBA(355.9,"AE",IBINS,IBPRV)) Q:'IBPRV S Z=0 F S Z=$O(^IBA(355.9,"AE",IBINS,IBPRV,Z)) Q:'Z S IB=$G(^IBA(355.9,Z,0)) D
.. Q:$P(IB,U,4)=""!($P(IB,U,5)="")!($P(IB,U,6)="")!($P(IB,U,16)="")
.. I IBSORT,$S(IBDSP="I":IBPRV'=IBSORT,1:$P(IB,U,6)'=IBSORT) Q
.. S IB1=$S(IBDSP="A":$P(IB,U,6),1:U_$$EXPAND^IBTRE(355.9,.01,IBPRV)_U_IBPRV)
.. S IB2=$S(IBDSP="I":$P(IB,U,6),1:U_$$EXPAND^IBTRE(355.9,.01,IBPRV)_U_IBPRV)
.. S ^TMP("IBPRV_INS_SORT",$J,IB1,IB2,$P(IB,U,4),$P(IB,U,5),$P(IB,U,16),Z)=$P(IB,U,7)_U_IBPRV
;
S IBOSRT1=""
S IBSRT1="" F S IBSRT1=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1)) Q:IBSRT1="" D
. S IBSRT2="",IBOSRT2=""
. F S IBSRT2=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2)) Q:IBSRT2="" D
.. I IBOSRT1'=IBSRT1 D
... I IBOSRT1'="" S IBLCT=IBLCT+1 D SET^VALM10(IBLCT," ",IBCT+1)
... S IBLCT=IBLCT+1 D SET^VALM10(IBLCT,$S(IBDSP'="I":"ID Qualifier",1:"Provider")_": "_$S(IBDSP'="I":$$EXPAND^IBTRE(355.91,.06,IBSRT1),1:$P(IBSRT1,U,2_$S($P(IBSRT2,U,3)["VA(200":" (VA)",1:"(NON-VA)"))),IBCT+1)
... S IBOSRT1=IBSRT1
.. ;
.. S FT="" F S FT=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT)) Q:FT="" S CT="" F S CT=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT,CT)) Q:CT="" D
... S CU="" F S CU=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT,CT,CU)) Q:CU="" S Z=0 F S Z=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT,CT,CU,Z)) Q:'Z S IB=$G(^(Z)) D
.... S IBLCT=IBLCT+1,IBCT=IBCT+1
.... S Z0=$E(IBCT_$J("",4),1,4)_" "
.... I IBDSP'="I" S Z0=Z0_$E($S(IBOSRT2'=IBSRT2:$P(IBSRT2,U,2),1:"")_$J("",20),1,20)
.... I IBDSP="I" S Z0=Z0_$E($S(IBOSRT2'=IBSRT2:$$EXPAND^IBTRE(355.9,.06,IBSRT2),1:"")_$J("",20),1,20)
.... S IBOSRT2=IBSRT2
.... ;JRA IB*2.0*592
.... S Z0=Z0_" "_$S(FT=1:"UB-04",FT=2:"1500",1:"BOTH ")_" "_$E($S(CT=3:"RX",CT=1:"INPT",CT=2:"OUTPT",1:"INPT/OUTPT")_$J("",11),1,11) ;JWS;JRA IB*2.0*592
.... S Z0=Z0_" "_$E($S(CU'="*N/A*":$P($G(^IBA(355.95,+$P($G(^IBA(355.96,+CU,0)),U),0)),U),1:"")_$J("",15),1,15) ;JWS;JRA IB*2.0*592
.... D SET^VALM10(IBLCT,Z0_" "_$P(IB,U),IBCT)
.... S ^TMP("IBPRV_INS_ID",$J,"ZIDX",IBCT)=Z,^(IBCT,"PRV")=$P(IB,U,2)
.... I '$D(^TMP("IBPRV_INS_ID",$J,$S(IBDSP="I":"ZXPRV",1:"ZXPTYP"),IBSRT1)) S ^(IBSRT1)=IBLCT-1
K ^TMP("IBPRV_INS_SORT",$J)
;
I IBLCT=0 D G BLDQ ; No entries found
. D SET^VALM10(1," ")
. S Z=" No "_$S(IBDSP="D":"default ",1:"")
. S Z=Z_"ID's found for "_$S(IBDSP="I":"provider "_$S(IBSORT:"("_$$EXPAND^IBTRE(355.9,.01,IBSORT)_") ",1:"")_"and ",IBDSP="A":"provider type "_$S(IBSORT:"("_$$EXPAND^IBTRE(355.9,.06,IBSORT)_") ",1:"")_"and ",1:"")_"insurance co"
. D SET^VALM10(2,Z)
. S IBLCT=2
;
BLDQ S VALMCNT=IBLCT,VALMBG=1
Q
;
EXPND ;
Q
;
HELP ;
Q
;
EXIT ;
K IBFASTXT
D COPYPROV^IBCEP5A(IBINS)
K ^TMP("IBPRV_INS_ID",$J)
D CLEAN^VALM10
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_INS_ID",$J,"ZIDX",Z))_U_$G(^(Z,"PRV"))
Q
;
ENX(IBINS1) ; Insurance co level defaults for all providers or
; for all providers by care unit
N DIC,DIE,DR,DA,X,Y,DLAYGO
I '$G(IBINS1) D G:'$G(IBINS1) ENQ
. S DIC="^IBA(355.91,",DIC(0)="AELMQ",DLAYGO=355.91 D ^DIC
. I Y>0 S IBINS1=+Y
S DIE="^IBA(355.91,",DA=IBINS1,DR=".01;.06;.04;.05;.03;.07" D ^DIE
;
ENQ Q
;
PPTYP(IBINS) ; Returns the ien of the default performing provider type for
; insurance company IBINS (ien file 36)
Q +$G(^DIC(36,+IBINS,4))
;
SCREEN(WHICH) ; This screen is used the menu protocol to screen out the ID functions if it is a child ins co
Q:'$G(DA) 0
Q:'$G(DA(1)) 0
N FILE,IENS,FIELD,FLAG,TARGET
S FILE=101.01,IENS=DA_","_DA(1),FIELD=".01",FLAG="I"
D GETS^DIQ(FILE,IENS,FIELD,FLAG,"TARGET")
Q:'$D(TARGET) 0
N IEN
S IEN=$G(TARGET(FILE,IENS_",",FIELD,FLAG))
Q:'+IEN 0
S FILE=101,FIELD=1,FLAG="E"
K TARGET
D GETS^DIQ(FILE,IEN,FIELD,FLAG,"TARGET")
Q:'$D(TARGET) 0
I $G(TARGET(FILE,IEN_",",FIELD,FLAG))'[WHICH Q 1
Q:'$G(IBINS) 0
N PCF
S PCF=$P($G(^DIC(36,+IBINS,3)),U,13)
I PCF="C" Q 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEP0 9228 printed Apr 09, 2024@21:27:58 Page 2
IBCEP0 ;ALB/TMP - Functions for PROVIDER ID MAINTENANCE ;13-DEC-99
+1 ;;2.0;INTEGRATED BILLING;**137,191,239,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 INS ID
+1 ; Variables should be available throughout actions
NEW IBINS,IBDSP,IBSORT,IBPRV
+2 KILL IBFASTXT
+3 DO FULL^VALM1
+4 DO EN^VALM("IBCE PRVINS ID")
+5 QUIT
+6 ;
EN1(IBINS) ; Entrypoint from insurance co maintenance
+1 ; Variables should be available throughout actions
NEW IBDSP,IBSORT
+2 DO FULL^VALM1
+3 DO EN^VALM("IBCE PRVINS ID FROM INS MAINT")
+4 QUIT
+5 ;
HDR ; -- header code
+1 NEW Z,Z0,Z1,IBCT,IBPPTYP,IBEMCTYP
+2 SET IBCT=1
+3 KILL VALMHDR
+4 IF $GET(IBINS)
Begin DoDot:1
+5 NEW PCF,PCDISP
+6 SET PCF=$PIECE($GET(^DIC(36,+IBINS,3)),U,13)
+7 SET PCDISP=$SELECT(PCF="C":"(Child)",PCF="P":"(Parent)",1:"")
+8 SET VALMHDR(1)="Insurance Co: "_$PIECE($GET(^DIC(36,+IBINS,0)),U)_" "_PCDISP
+9 ; Get performing provider id type for insurance co
+10 SET IBPPTYP=$$PPTYP(IBINS)
+11 ; Get ien of EMC ID from file 355.97
+12 SET IBEMCTYP=+$$EMCID^IBCEP()
+13 IF $GET(IBSORT)="ALL"!($GET(IBDSP)="I")!($GET(IBSORT)=IBPPTYP)!($GET(IBSORT)=IBEMCTYP)
Begin DoDot:2
+14 ; Look for care unit in either of these id types - if there, report on line 2 of header
+15 IF $GET(IBSORT)=IBPPTYP
SET IBEMCTYP=0
+16 IF $GET(IBSORT)=IBEMCTYP
SET IBPPTYP=0
+17 FOR Z0=IBPPTYP_"P",IBEMCTYP_"E"
SET Z1=""
FOR
SET Z1=$ORDER(^IBA(355.96,"D",+IBINS,+Z0,Z1))
if Z1=""
QUIT
IF Z1'="*N/A*"
SET Z($EXTRACT(Z0,$LENGTH(Z0)))=1
QUIT
+18 IF $DATA(Z("P"))!$DATA(Z("E"))
Begin DoDot:3
+19 SET IBCT=IBCT+1
+20 SET VALMHDR(IBCT)=" "_$SELECT($DATA(Z("P")):"PERFORMING PROV ID"_$SELECT($DATA(Z("E")):" AND ",1:""),1:"")_$SELECT($DATA(Z("E")):"EMC PROV ID",1:"")_" MAY REQUIRE CARE UNIT"
End DoDot:3
End DoDot:2
+21 IF $DATA(Z("P"))!$DATA(Z("E"))
SET IBCT=IBCT+1
SET VALMHDR(IBCT)=" "
+22 SET IBCT=IBCT+1
SET VALMHDR(IBCT)=" PROVIDER "_$SELECT($GET(IBDSP)="I":"ID TYPE",1:"NAME ")_$JUSTIFY("",6)_"FORM CARE TYPE CARE UNIT ID#"
End DoDot:1
+23 QUIT
+24 ;
INIT ; Initialization
+1 ; This will be to keep track of ID's edited during this session
KILL ^TMP("IB_EDITED_IDS",$JOB)
+2 DO INSID(.IBINS,.IBDSP,.IBSORT)
+3 IF $GET(IBDSP)="I"
IF $GET(IBSORT)
SET IBPRV=IBSORT
+4 IF '$GET(IBINS)
SET VALMQUIT=1
+5 QUIT
+6 ;
INSID(IBINS,IBDSP,IBSORT) ;
+1 NEW DIC,DIR,DA,X,Y,IBOK,DTOUT,DUOUT
+2 SET IBOK=1
+3 IF '$GET(IBINS)
Begin DoDot:1
+4 SET DIC(0)="AEMQ"
SET DIC="^DIC(36,"
DO ^DIC
+5 IF Y'>0
SET IBOK=0
QUIT
+6 SET IBINS=+Y
End DoDot:1
+7 IF '$GET(IBINS)
SET IBOK=0
+8 IF 'IBOK
GOTO INSIDQ
+9 ;
+10 SET DIR(0)="SA^D:INSURANCE CO DEFAULT IDS;I:INDIVIDUAL PROVIDER IDS FURNISHED BY THE INS CO;A:ALL IDS FURNISHED BY THE INS CO BY PROVIDER TYPE"
+11 SET DIR("A")="SELECT DISPLAY CONTENT: "
SET DIR("B")="A"
+12 SET DIR("?",1)="(D) DISPLAY CONTAINS ONLY THOSE IDS ASSIGNED AS DEFAULTS TO THE FACILITY BY"
SET DIR("?",2)=" THE INSURANCE COMPANY"
+13 SET DIR("?",3)="(I) DISPLAY CONTAINS ONLY THOSE IDS ASSIGNED TO INDIVIDUAL PROVIDERS BY THE"
SET DIR("?",4)=" INSURANCE COMPANY"
+14 SET DIR("?",5)="(A) DISPLAY CONTAINS ALL IDS ASSIGNED BY THE INSURANCE COMPANY FOR ONE OR ALL"
SET DIR("?")=" PROVIDER ID TYPES"
+15 WRITE !
DO ^DIR
KILL DIR
WRITE !
+16 IF $DATA(DTOUT)!$DATA(DUOUT)!("DIA"'[Y)
SET IBOK=0
GOTO INSIDQ
+17 SET IBDSP=Y
SET IBSORT=""
+18 IF IBDSP="A"!(IBDSP="I")
FOR
Begin DoDot:1
+19 ;
+20 IF IBDSP="A"
Begin DoDot:2
+21 SET DIR("A")="Display only IDs with a specific ID Qualifier?: "
+22 SET DIR("?",1)="Answer Yes to select a specific ID Qualifier by which to display IDs."
+23 SET DIR("?")="Answer No to display all IDs."
+24 QUIT
End DoDot:2
+25 ;
+26 IF IBDSP="I"
Begin DoDot:2
+27 SET DIR("A")="Display IDs for a specific Provider?: "
+28 SET DIR("?",1)="Answer Yes to select a specific Provider."
+29 SET DIR("?")="Answer No to display all Providers."
+30 QUIT
End DoDot:2
+31 ;
+32 SET DIR("B")="NO"
SET DIR(0)="YA"
+33 WRITE !
DO ^DIR
KILL DIR
WRITE !
+34 IF $DATA(DTOUT)!$DATA(DUOUT)
SET IBOK=0
QUIT
+35 IF Y'=1
SET IBSORT="ALL"
QUIT
+36 ;
+37 IF IBDSP="A"
Begin DoDot:2
+38 SET DIC(0)="AEMQ"
SET DIC="^IBE(355.97,"
SET DIC("S")="I $S('$P(^(0),U,2):1,1:$P(^(0),U,2)=3)"
+39 SET DIC("A")="Select type of ID Qualifier: "
+40 DO ^DIC
KILL DIC
+41 IF Y>0
SET IBSORT=+Y
QUIT
+42 IF $DATA(DTOUT)!$DATA(DUOUT)
SET IBOK=0
End DoDot:2
QUIT
+43 ;
+44 IF IBDSP="I"
Begin DoDot:2
+45 NEW DA
+46 SET DIR(0)="399.0222,.02A"
SET DIR("A")="SELECT PROVIDER: "
+47 WRITE !
DO ^DIR
KILL DIR
WRITE !
+48 IF Y>0
SET IBSORT=Y
QUIT
+49 IF $DATA(DTOUT)!$DATA(DUOUT)
SET IBOK=0
QUIT
End DoDot:2
QUIT
+50 SET IBOK=0
QUIT
End DoDot:1
if 'IBOK!(IBSORT'="")
QUIT
+51 ;
+52 if 'IBOK
GOTO INSIDQ
+53 DO BLD(IBINS,IBDSP,IBSORT)
INSIDQ IF 'IBOK
SET VALMQUIT=1
+1 QUIT
+2 ;
BLD(IBINS,IBDSP,IBSORT) ; Build display for Insurance co level provider ID's
+1 NEW IB,IBENT,IBLCT,IBCT,IBPRV,IBSRT1,IBSRT2,IBOSRT1,IBOSRT2,CU,FT,PT,CT,Z,Z0
+2 KILL ^TMP("IBPRV_INS_ID",$JOB),^TMP("IBPRV_INS_SORT",$JOB)
+3 ;
+4 SET (IBENT,IBCT,IBLCT)=0
+5 ;
+6 IF "DA"[$GET(IBDSP)
Begin DoDot:1
+7 SET CU=""
FOR
SET CU=$ORDER(^IBA(355.91,"AUNIQ",IBINS,CU))
if CU=""
QUIT
SET FT=""
FOR
SET FT=$ORDER(^IBA(355.91,"AUNIQ",IBINS,CU,FT))
if FT=""
QUIT
Begin DoDot:2
+8 SET CT=""
FOR
SET CT=$ORDER(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT))
if CT=""
QUIT
SET PT=0
FOR
SET PT=$SELECT(IBDSP="A"&IBSORT:IBSORT,1:$ORDER(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT,PT)))
if 'PT
QUIT
Begin DoDot:3
+9 SET Z=0
FOR
SET Z=$ORDER(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT,PT,Z))
if 'Z
QUIT
SET IB=$GET(^IBA(355.91,Z,0))
SET ^TMP("IBPRV_INS_SORT",$JOB,PT,"^<<INS CO DEFAULT>>",FT,CT,CU,Z)=$PIECE(IB,U,7)_U
End DoDot:3
if IBDSP="A"&IBSORT
QUIT
End DoDot:2
End DoDot:1
+10 ;
+11 IF "IA"[$GET(IBDSP)
Begin DoDot:1
+12 SET IBPRV=""
+13 NEW IB1,IB2
+14 FOR
SET IBPRV=$ORDER(^IBA(355.9,"AE",IBINS,IBPRV))
if 'IBPRV
QUIT
SET Z=0
FOR
SET Z=$ORDER(^IBA(355.9,"AE",IBINS,IBPRV,Z))
if 'Z
QUIT
SET IB=$GET(^IBA(355.9,Z,0))
Begin DoDot:2
+15 if $PIECE(IB,U,4)=""!($PIECE(IB,U,5)="")!($PIECE(IB,U,6)="")!($PIECE(IB,U,16)="")
QUIT
+16 IF IBSORT
IF $SELECT(IBDSP="I":IBPRV'=IBSORT,1:$PIECE(IB,U,6)'=IBSORT)
QUIT
+17 SET IB1=$SELECT(IBDSP="A":$PIECE(IB,U,6),1:U_$$EXPAND^IBTRE(355.9,.01,IBPRV)_U_IBPRV)
+18 SET IB2=$SELECT(IBDSP="I":$PIECE(IB,U,6),1:U_$$EXPAND^IBTRE(355.9,.01,IBPRV)_U_IBPRV)
+19 SET ^TMP("IBPRV_INS_SORT",$JOB,IB1,IB2,$PIECE(IB,U,4),$PIECE(IB,U,5),$PIECE(IB,U,16),Z)=$PIECE(IB,U,7)_U_IBPRV
End DoDot:2
End DoDot:1
+20 ;
+21 SET IBOSRT1=""
+22 SET IBSRT1=""
FOR
SET IBSRT1=$ORDER(^TMP("IBPRV_INS_SORT",$JOB,IBSRT1))
if IBSRT1=""
QUIT
Begin DoDot:1
+23 SET IBSRT2=""
SET IBOSRT2=""
+24 FOR
SET IBSRT2=$ORDER(^TMP("IBPRV_INS_SORT",$JOB,IBSRT1,IBSRT2))
if IBSRT2=""
QUIT
Begin DoDot:2
+25 IF IBOSRT1'=IBSRT1
Begin DoDot:3
+26 IF IBOSRT1'=""
SET IBLCT=IBLCT+1
DO SET^VALM10(IBLCT," ",IBCT+1)
+27 SET IBLCT=IBLCT+1
DO SET^VALM10(IBLCT,$SELECT(IBDSP'="I":"ID Qualifier",1:"Provider")_": "_$SELECT(IBDSP'="I":$$EXPAND^IBTRE(355.91,.06,IBSRT1),1:$PIECE(IBSRT1,U,2_$SELECT($PIECE(IBSRT2,U,3)["VA(200":" (VA)",1:"(NON-VA)"))),IBCT+1)
+28 SET IBOSRT1=IBSRT1
End DoDot:3
+29 ;
+30 SET FT=""
FOR
SET FT=$ORDER(^TMP("IBPRV_INS_SORT",$JOB,IBSRT1,IBSRT2,FT))
if FT=""
QUIT
SET CT=""
FOR
SET CT=$ORDER(^TMP("IBPRV_INS_SORT",$JOB,IBSRT1,IBSRT2,FT,CT))
if CT=""
QUIT
Begin DoDot:3
+31 SET CU=""
FOR
SET CU=$ORDER(^TMP("IBPRV_INS_SORT",$JOB,IBSRT1,IBSRT2,FT,CT,CU))
if CU=""
QUIT
SET Z=0
FOR
SET Z=$ORDER(^TMP("IBPRV_INS_SORT",$JOB,IBSRT1,IBSRT2,FT,CT,CU,Z))
if 'Z
QUIT
SET IB=$GET(^(Z))
Begin DoDot:4
+32 SET IBLCT=IBLCT+1
SET IBCT=IBCT+1
+33 SET Z0=$EXTRACT(IBCT_$JUSTIFY("",4),1,4)_" "
+34 IF IBDSP'="I"
SET Z0=Z0_$EXTRACT($SELECT(IBOSRT2'=IBSRT2:$PIECE(IBSRT2,U,2),1:"")_$JUSTIFY("",20),1,20)
+35 IF IBDSP="I"
SET Z0=Z0_$EXTRACT($SELECT(IBOSRT2'=IBSRT2:$$EXPAND^IBTRE(355.9,.06,IBSRT2),1:"")_$JUSTIFY("",20),1,20)
+36 SET IBOSRT2=IBSRT2
+37 ;JRA IB*2.0*592
+38 ;JWS;JRA IB*2.0*592
SET Z0=Z0_" "_$SELECT(FT=1:"UB-04",FT=2:"1500",1:"BOTH ")_" "_$EXTRACT($SELECT(CT=3:"RX",CT=1:"INPT",CT=2:"OUTPT",1:"INPT/OUTPT")_$JUSTIFY("",11),1,11)
+39 ;JWS;JRA IB*2.0*592
SET Z0=Z0_" "_$EXTRACT($SELECT(CU'="*N/A*":$PIECE($GET(^IBA(355.95,+$PIECE($GET(^IBA(355.96,+CU,0)),U),0)),U),1:"")_$JUSTIFY("",15),1,15)
+40 DO SET^VALM10(IBLCT,Z0_" "_$PIECE(IB,U),IBCT)
+41 SET ^TMP("IBPRV_INS_ID",$JOB,"ZIDX",IBCT)=Z
SET ^(IBCT,"PRV")=$PIECE(IB,U,2)
+42 IF '$DATA(^TMP("IBPRV_INS_ID",$JOB,$SELECT(IBDSP="I":"ZXPRV",1:"ZXPTYP"),IBSRT1))
SET ^(IBSRT1)=IBLCT-1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+43 KILL ^TMP("IBPRV_INS_SORT",$JOB)
+44 ;
+45 ; No entries found
IF IBLCT=0
Begin DoDot:1
+46 DO SET^VALM10(1," ")
+47 SET Z=" No "_$SELECT(IBDSP="D":"default ",1:"")
+48 SET Z=Z_"ID's found for "_$SELECT(IBDSP="I":"provider "_$SELECT(IBSORT:"("_$$EXPAND^IBTRE(355.9,.01,IBSORT)_") ",1:"")_"and ",IBDSP="A":"provider type "_$SELECT(IBSORT:"("_$$EXPAND^IBTRE(355.9,.06,IBSORT)_") ",1:"")_"and ",1:"")_"insura
nce co"
+49 DO SET^VALM10(2,Z)
+50 SET IBLCT=2
End DoDot:1
GOTO BLDQ
+51 ;
BLDQ SET VALMCNT=IBLCT
SET VALMBG=1
+1 QUIT
+2 ;
EXPND ;
+1 QUIT
+2 ;
HELP ;
+1 QUIT
+2 ;
EXIT ;
+1 KILL IBFASTXT
+2 DO COPYPROV^IBCEP5A(IBINS)
+3 KILL ^TMP("IBPRV_INS_ID",$JOB)
+4 DO CLEAN^VALM10
+5 QUIT
+6 ;
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_INS_ID",$JOB,"ZIDX",Z))_U_$GET(^(Z,"PRV"))
+8 QUIT
+9 ;
ENX(IBINS1) ; Insurance co level defaults for all providers or
+1 ; for all providers by care unit
+2 NEW DIC,DIE,DR,DA,X,Y,DLAYGO
+3 IF '$GET(IBINS1)
Begin DoDot:1
+4 SET DIC="^IBA(355.91,"
SET DIC(0)="AELMQ"
SET DLAYGO=355.91
DO ^DIC
+5 IF Y>0
SET IBINS1=+Y
End DoDot:1
if '$GET(IBINS1)
GOTO ENQ
+6 SET DIE="^IBA(355.91,"
SET DA=IBINS1
SET DR=".01;.06;.04;.05;.03;.07"
DO ^DIE
+7 ;
ENQ QUIT
+1 ;
PPTYP(IBINS) ; Returns the ien of the default performing provider type for
+1 ; insurance company IBINS (ien file 36)
+2 QUIT +$GET(^DIC(36,+IBINS,4))
+3 ;
SCREEN(WHICH) ; This screen is used the menu protocol to screen out the ID functions if it is a child ins co
+1 if '$GET(DA)
QUIT 0
+2 if '$GET(DA(1))
QUIT 0
+3 NEW FILE,IENS,FIELD,FLAG,TARGET
+4 SET FILE=101.01
SET IENS=DA_","_DA(1)
SET FIELD=".01"
SET FLAG="I"
+5 DO GETS^DIQ(FILE,IENS,FIELD,FLAG,"TARGET")
+6 if '$DATA(TARGET)
QUIT 0
+7 NEW IEN
+8 SET IEN=$GET(TARGET(FILE,IENS_",",FIELD,FLAG))
+9 if '+IEN
QUIT 0
+10 SET FILE=101
SET FIELD=1
SET FLAG="E"
+11 KILL TARGET
+12 DO GETS^DIQ(FILE,IEN,FIELD,FLAG,"TARGET")
+13 if '$DATA(TARGET)
QUIT 0
+14 IF $GET(TARGET(FILE,IEN_",",FIELD,FLAG))'[WHICH
QUIT 1
+15 if '$GET(IBINS)
QUIT 0
+16 NEW PCF
+17 SET PCF=$PIECE($GET(^DIC(36,+IBINS,3)),U,13)
+18 IF PCF="C"
QUIT 0
+19 QUIT 1
