- IBCEP ;ALB/TMP - Functions for PROVIDER ID MAINT - INS CO PARAMS ;11-02-00
- ;;2.0;INTEGRATED BILLING;**137,232,320,348,349,592**;21-MAR-94;Build 58
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- EN ; -- main entry point for IBCE PRV INS PARAMS
- N IBINS,IBCUINC ; Variable should be available throughout actions
- D FULL^VALM1
- D EN^VALM("IBCE PRV INS PARAMS")
- Q
- ;
- HDR ; -- header code
- K VALMHDR
- I $G(IBINS) S VALMHDR(1)="INSURANCE CO: "_$P($G(^DIC(36,+IBINS,0)),U)
- Q
- ;
- INIT ; Initialization
- N DIR,DIC,DA,X,Y,DTOUT,DUOUT
- S DIC(0)="AEMQ",DIC="^DIC(36," D ^DIC
- I Y'>0 D
- . S VALMQUIT=1
- E D
- . S DIR="YA",DIR("A")="DO YOU WANT TO INCLUDE ANY CARE UNIT DETAIL?: ",DIR("?",1)="If you want to see the specific care unit defined for the insurance co",DIR("?")="you should respond yes here"
- . W ! D ^DIR K DIR W !
- . I $D(DTOUT)!$D(DUOUT) S VALMQUIT=1 Q
- . S IBCUINC=(Y=1)
- . S IBINS=+Y D BLD(IBINS,IBCUINC)
- Q
- ;
- BLD(IBINS,IBCUINC) ; Build display for ins co level provider ID parameters
- ; IBINS = ien of ins co (file 36)
- ; IBCUINC = flag:
- ; = 1 if care unit list should be included or 0 if not
- N A,A0,A1,A2,A3,Z0,IB1,IB12,IB4,IBLCT,IBPTYP
- S IBLCT=0
- S IB4=$G(^DIC(36,IBINS,4))
- K ^TMP("IBPRV_INS_ID_PARAMS",$J)
- ;
- S Z0="Perf Prov Secondary ID Type (1500): "_$E($$EXPAND^IBTRE(36,4.01,+$P(IB4,U))_$J("",20),1,20) D SET1(.IBLCT,Z0)
- S Z0="Perf Prov Secondary ID Type (UB04): "_$E($$EXPAND^IBTRE(36,4.02,+$P(IB4,U,2))_$J("",20),1,20) D SET1(.IBLCT,Z0)
- S Z0=$J("",20)_"Required: "_$$EXPAND^IBTRE(36,4.03,$P(IB4,U,3)) D SET1(.IBLCT,Z0)
- S Z0=$J("",10)_"Care Unit Name: "_$$EXPAND^IBTRE(36,4.09,$P(IB4,U,9)) D SET1(.IBLCT,Z0)
- S Z0="" D SET1(.IBLCT,Z0)
- ;
- I '$D(^IBA(355.96,"D",IBINS)) D G BLDQ ;No care unit needed
- . S Z0=$J("",7)_"*** NO CARE UNITS DEFINED FOR THIS INS CO PROVIDER SECONDARY ID ***" D SET1(.IBLCT,Z0)
- ;
- S Z0=$J("",17)_"VALID CARE UNITS FOR THIS INSURANCE COMPANY" D SET1(.IBLCT,Z0),CNTRL^VALM10(IBLCT,18,46,IORVON,IORVOFF)
- S A=0
- F S A=$O(^IBA(355.96,"AC",IBINS,A)) Q:'A S IBPTYP=$P($G(^IBE(355.97,A,0)),U) I IBPTYP'="" D
- . S A2=IBPTYP_U_A,^TMP("IBPRV_INS_ID_PARAMS_SORT",$J,A2)=""
- . S A0=0 F S A0=$O(^IBA(355.96,"AC",IBINS,A,A0)) Q:'A0 S A1=$G(^IBA(355.96,A0,0)) D
- .. I '$G(IBCUINC) S:'$D(^TMP("IBPRV_INS_ID_PARAMS_SORT",$J,A2,$P(A1,U,4)_U_$P(A1,U,5))) ^($P(A1,U,4)_U_$P(A1,U,5))="" Q
- .. I $P(A1,U,4)'="",$P(A1,U,5)'="" D
- ... S A3=$E($P($G(^IBE(355.95,+A1,0)),U)_$J("",1,30),1,30)_U_$S($P($G(^(0)),U,2)'="":$P(^(0),U,2),1:"<No description available>")
- ... I '$D(^TMP("IBPRV_INS_ID_PARAMS_SORT",$J,A2,$P(A1,U,4)_U_$P(A1,U,5),$P(A3,U))) S ^($P(A3,U))=$P(A3,U,2)
- . ; records are fully sorted
- S A=""
- F S A=$O(^TMP("IBPRV_INS_ID_PARAMS_SORT",$J,A)) Q:'A S A2="PROVIDER ID TYPE: "_$P(A,U),IB1=1 D:'IB1 SET1(.IBLCT,"") D SET1(.IBLCT,A2) S IB12=1 S:$G(IBCUINC) IB1=0 D
- . S A0="" F S A0=$O(^TMP("IBPRV_INS_ID_PARAMS_SORT",$J,A,A0)) Q:A0="" D
- .. S Z0=$J("",5)_"FORM TYPE: "_$E($$EXPAND^IBTRE(355.96,.04,$P(A0,U))_$J("",25),1,25)_" CARE TYPE: "_$E($$EXPAND^IBTRE(355.96,.05,$P(A0,U,2))_$J("",25),1,25)
- .. D:'IB12 SET1(.IBLCT,"") D SET1(.IBLCT,Z0)
- .. Q:'$G(IBCUINC)
- .. S IB12=0
- .. S A1="" F S A1=$O(^TMP("IBPRV_INS_ID_PARAMS_SORT",$J,A,A0,A1)) Q:A1="" S Z0=$J("",10)_A1_$G(^(A1)) D SET1(.IBLCT,Z0)
- ;
- BLDQ K ^TMP("IBPRV_INS_ID_PARAMS_SORT",$J)
- S VALMCNT=IBLCT,VALMBG=1
- Q
- ;
- SET1(IBLCT,Z0) ;
- S IBLCT=IBLCT+1 D SET^VALM10(IBLCT,Z0)
- Q
- ;
- EXPND ;
- Q
- ;
- HELP ;
- Q
- ;
- EXIT ;
- K ^TMP("IBPRV_INS_ID_PARAMS",$J)
- D CLEAN^VALM10
- Q
- ;
- EDIT ; Entrypoint called from IBCSCE to invoke provider id edit functions
- Q
- ;
- EDIT1 ; Edit parameters
- N IB,IBY,IBCNS,DIE,DR,X,Y
- D FULL^VALM1
- S IBCNS=IBINS,IBY=12
- D MAIN^IBCNSC1
- S VALMBCK="R"
- Q
- ;
- NETID() ; Returns the ien of the entry in file 355.97 that is designated as the
- ; NETWORK ID
- N Z S Z=0 F S Z=$O(^IBE(355.97,Z)) Q:'Z Q:$P($G(^(Z,1)),U,6)
- Q Z
- ;
- EMCID() ; Returns the ien of the entry in file 355.97 that is designated as the
- ; EMC ID
- N Z S Z=0 F S Z=$O(^IBE(355.97,Z)) Q:'Z Q:$P($G(^(Z,1)),U,5)
- Q Z
- ;
- UPIN() ; Returns the ien of the entry in file 355.97 that is designated as the
- ; UPIN ID
- Q +$O(^IBE(355.97,"B","UPIN",0))
- ;
- EDITID(IBCNS) ; Edit provider id's from insurance co enter/edit
- ; IBCNS = ien of file 36
- Q ; WCJ 12/30/2005
- N X,Y,Z4,DIR
- S Z4=$G(^DIC(36,IBCNS,4))
- I 'Z4,'$P(Z4,U,2) Q
- S DIR("A",1)="USE PROVIDER ID MAINTENANCE TO ENTER/EDIT PROV SECONDARY ID'S FOR THIS CO.",DIR("A")="PRESS RETURN TO CONTINUE: ",DIR(0)="EA" W ! D ^DIR K DIR
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEP 4613 printed Feb 18, 2025@23:37:51 Page 2
- IBCEP ;ALB/TMP - Functions for PROVIDER ID MAINT - INS CO PARAMS ;11-02-00
- +1 ;;2.0;INTEGRATED BILLING;**137,232,320,348,349,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 PARAMS
- +1 ; Variable should be available throughout actions
- NEW IBINS,IBCUINC
- +2 DO FULL^VALM1
- +3 DO EN^VALM("IBCE PRV INS PARAMS")
- +4 QUIT
- +5 ;
- HDR ; -- header code
- +1 KILL VALMHDR
- +2 IF $GET(IBINS)
- SET VALMHDR(1)="INSURANCE CO: "_$PIECE($GET(^DIC(36,+IBINS,0)),U)
- +3 QUIT
- +4 ;
- INIT ; Initialization
- +1 NEW DIR,DIC,DA,X,Y,DTOUT,DUOUT
- +2 SET DIC(0)="AEMQ"
- SET DIC="^DIC(36,"
- DO ^DIC
- +3 IF Y'>0
- Begin DoDot:1
- +4 SET VALMQUIT=1
- End DoDot:1
- +5 IF '$TEST
- Begin DoDot:1
- +6 SET DIR="YA"
- SET DIR("A")="DO YOU WANT TO INCLUDE ANY CARE UNIT DETAIL?: "
- SET DIR("?",1)="If you want to see the specific care unit defined for the insurance co"
- SET DIR("?")="you should respond yes here"
- +7 WRITE !
- DO ^DIR
- KILL DIR
- WRITE !
- +8 IF $DATA(DTOUT)!$DATA(DUOUT)
- SET VALMQUIT=1
- QUIT
- +9 SET IBCUINC=(Y=1)
- +10 SET IBINS=+Y
- DO BLD(IBINS,IBCUINC)
- End DoDot:1
- +11 QUIT
- +12 ;
- BLD(IBINS,IBCUINC) ; Build display for ins co level provider ID parameters
- +1 ; IBINS = ien of ins co (file 36)
- +2 ; IBCUINC = flag:
- +3 ; = 1 if care unit list should be included or 0 if not
- +4 NEW A,A0,A1,A2,A3,Z0,IB1,IB12,IB4,IBLCT,IBPTYP
- +5 SET IBLCT=0
- +6 SET IB4=$GET(^DIC(36,IBINS,4))
- +7 KILL ^TMP("IBPRV_INS_ID_PARAMS",$JOB)
- +8 ;
- +9 SET Z0="Perf Prov Secondary ID Type (1500): "_$EXTRACT($$EXPAND^IBTRE(36,4.01,+$PIECE(IB4,U))_$JUSTIFY("",20),1,20)
- DO SET1(.IBLCT,Z0)
- +10 SET Z0="Perf Prov Secondary ID Type (UB04): "_$EXTRACT($$EXPAND^IBTRE(36,4.02,+$PIECE(IB4,U,2))_$JUSTIFY("",20),1,20)
- DO SET1(.IBLCT,Z0)
- +11 SET Z0=$JUSTIFY("",20)_"Required: "_$$EXPAND^IBTRE(36,4.03,$PIECE(IB4,U,3))
- DO SET1(.IBLCT,Z0)
- +12 SET Z0=$JUSTIFY("",10)_"Care Unit Name: "_$$EXPAND^IBTRE(36,4.09,$PIECE(IB4,U,9))
- DO SET1(.IBLCT,Z0)
- +13 SET Z0=""
- DO SET1(.IBLCT,Z0)
- +14 ;
- +15 ;No care unit needed
- IF '$DATA(^IBA(355.96,"D",IBINS))
- Begin DoDot:1
- +16 SET Z0=$JUSTIFY("",7)_"*** NO CARE UNITS DEFINED FOR THIS INS CO PROVIDER SECONDARY ID ***"
- DO SET1(.IBLCT,Z0)
- End DoDot:1
- GOTO BLDQ
- +17 ;
- +18 SET Z0=$JUSTIFY("",17)_"VALID CARE UNITS FOR THIS INSURANCE COMPANY"
- DO SET1(.IBLCT,Z0)
- DO CNTRL^VALM10(IBLCT,18,46,IORVON,IORVOFF)
- +19 SET A=0
- +20 FOR
- SET A=$ORDER(^IBA(355.96,"AC",IBINS,A))
- if 'A
- QUIT
- SET IBPTYP=$PIECE($GET(^IBE(355.97,A,0)),U)
- IF IBPTYP'=""
- Begin DoDot:1
- +21 SET A2=IBPTYP_U_A
- SET ^TMP("IBPRV_INS_ID_PARAMS_SORT",$JOB,A2)=""
- +22 SET A0=0
- FOR
- SET A0=$ORDER(^IBA(355.96,"AC",IBINS,A,A0))
- if 'A0
- QUIT
- SET A1=$GET(^IBA(355.96,A0,0))
- Begin DoDot:2
- +23 IF '$GET(IBCUINC)
- if '$DATA(^TMP("IBPRV_INS_ID_PARAMS_SORT",$JOB,A2,$PIECE(A1,U,4)_U_$PIECE(A1,U,5)))
- SET ^($PIECE(A1,U,4)_U_$PIECE(A1,U,5))=""
- QUIT
- +24 IF $PIECE(A1,U,4)'=""
- IF $PIECE(A1,U,5)'=""
- Begin DoDot:3
- +25 SET A3=$EXTRACT($PIECE($GET(^IBE(355.95,+A1,0)),U)_$JUSTIFY("",1,30),1,30)_U_$SELECT($PIECE($GET(^(0)),U,2)'="":$PIECE(^(0),U,2),1:"<No description available>")
- +26 IF '$DATA(^TMP("IBPRV_INS_ID_PARAMS_SORT",$JOB,A2,$PIECE(A1,U,4)_U_$PIECE(A1,U,5),$PIECE(A3,U)))
- SET ^($PIECE(A3,U))=$PIECE(A3,U,2)
- End DoDot:3
- End DoDot:2
- +27 ; records are fully sorted
- End DoDot:1
- +28 SET A=""
- +29 FOR
- SET A=$ORDER(^TMP("IBPRV_INS_ID_PARAMS_SORT",$JOB,A))
- if 'A
- QUIT
- SET A2="PROVIDER ID TYPE: "_$PIECE(A,U)
- SET IB1=1
- if 'IB1
- DO SET1(.IBLCT,"")
- DO SET1(.IBLCT,A2)
- SET IB12=1
- if $GET(IBCUINC)
- SET IB1=0
- Begin DoDot:1
- +30 SET A0=""
- FOR
- SET A0=$ORDER(^TMP("IBPRV_INS_ID_PARAMS_SORT",$JOB,A,A0))
- if A0=""
- QUIT
- Begin DoDot:2
- +31 SET Z0=$JUSTIFY("",5)_"FORM TYPE: "_$EXTRACT($$EXPAND^IBTRE(355.96,.04,$PIECE(A0,U))_$JUSTIFY("",25),1,25)_" CARE TYPE: "_$EXTRACT($$EXPAND^IBTRE(355.96,.05,$PIECE(A0,U,2))_$JUSTIFY("",25),1,25)
- +32 if 'IB12
- DO SET1(.IBLCT,"")
- DO SET1(.IBLCT,Z0)
- +33 if '$GET(IBCUINC)
- QUIT
- +34 SET IB12=0
- +35 SET A1=""
- FOR
- SET A1=$ORDER(^TMP("IBPRV_INS_ID_PARAMS_SORT",$JOB,A,A0,A1))
- if A1=""
- QUIT
- SET Z0=$JUSTIFY("",10)_A1_$GET(^(A1))
- DO SET1(.IBLCT,Z0)
- End DoDot:2
- End DoDot:1
- +36 ;
- BLDQ KILL ^TMP("IBPRV_INS_ID_PARAMS_SORT",$JOB)
- +1 SET VALMCNT=IBLCT
- SET VALMBG=1
- +2 QUIT
- +3 ;
- SET1(IBLCT,Z0) ;
- +1 SET IBLCT=IBLCT+1
- DO SET^VALM10(IBLCT,Z0)
- +2 QUIT
- +3 ;
- EXPND ;
- +1 QUIT
- +2 ;
- HELP ;
- +1 QUIT
- +2 ;
- EXIT ;
- +1 KILL ^TMP("IBPRV_INS_ID_PARAMS",$JOB)
- +2 DO CLEAN^VALM10
- +3 QUIT
- +4 ;
- EDIT ; Entrypoint called from IBCSCE to invoke provider id edit functions
- +1 QUIT
- +2 ;
- EDIT1 ; Edit parameters
- +1 NEW IB,IBY,IBCNS,DIE,DR,X,Y
- +2 DO FULL^VALM1
- +3 SET IBCNS=IBINS
- SET IBY=12
- +4 DO MAIN^IBCNSC1
- +5 SET VALMBCK="R"
- +6 QUIT
- +7 ;
- NETID() ; Returns the ien of the entry in file 355.97 that is designated as the
- +1 ; NETWORK ID
- +2 NEW Z
- SET Z=0
- FOR
- SET Z=$ORDER(^IBE(355.97,Z))
- if 'Z
- QUIT
- if $PIECE($GET(^(Z,1)),U,6)
- QUIT
- +3 QUIT Z
- +4 ;
- EMCID() ; Returns the ien of the entry in file 355.97 that is designated as the
- +1 ; EMC ID
- +2 NEW Z
- SET Z=0
- FOR
- SET Z=$ORDER(^IBE(355.97,Z))
- if 'Z
- QUIT
- if $PIECE($GET(^(Z,1)),U,5)
- QUIT
- +3 QUIT Z
- +4 ;
- UPIN() ; Returns the ien of the entry in file 355.97 that is designated as the
- +1 ; UPIN ID
- +2 QUIT +$ORDER(^IBE(355.97,"B","UPIN",0))
- +3 ;
- EDITID(IBCNS) ; Edit provider id's from insurance co enter/edit
- +1 ; IBCNS = ien of file 36
- +2 ; WCJ 12/30/2005
- QUIT
- +3 NEW X,Y,Z4,DIR
- +4 SET Z4=$GET(^DIC(36,IBCNS,4))
- +5 IF 'Z4
- IF '$PIECE(Z4,U,2)
- QUIT
- +6 SET DIR("A",1)="USE PROVIDER ID MAINTENANCE TO ENTER/EDIT PROV SECONDARY ID'S FOR THIS CO."
- SET DIR("A")="PRESS RETURN TO CONTINUE: "
- SET DIR(0)="EA"
- WRITE !
- DO ^DIR
- KILL DIR
- +7 QUIT
- +8 ;