- IBCEP5D ;ALB/JEH - EDI UTILITIES - for State License ;29-MAR-01
- ;;2.0;INTEGRATED BILLING;**137,320,348,349,592**;21-MAR-94;Build 58
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ; STATE LICENSE # ADD/EDIT DBIA ==> DBIA 224
- EN ;Add/edit state and license number
- N IBDA,DIR,DIC,DD,DA,DR,IBSTAT,IBLIC,IBQ,Y
- D FULL^VALM1
- I '$G(IBPRV) D G:IBQ STATQ
- . S IBQ=0
- . S DIC="^VA(200,",DIC(0)="AEMQ",DIC("A")="Select VA Provider: " D ^DIC K DIC
- . I $D(DTOUT)!$D(DUOUT)!(Y<0) S IBQ=1 Q
- . S IBDA=+Y
- I $G(IBPRV)["VA" S IBDA=+IBPRV
- I $G(IBPRV),$G(IBPRV)'["VA" D G STATQ
- . S DIR("A",1)="You have selected a Non-VA provider"
- . S DIR("A",2)="State license # can only be entered for VA providers"
- . S DIR("A",3)=""
- . S DIR("A")="Press enter to continue"
- . S DIR(0)="EA" W ! D ^DIR K DIR W !
- STALIC ;Add/edit file 200 field 54.1 multiple,state(.01) and license#(1) - DBIA 224
- ;
- S DA(1)=IBDA,DIC="^VA(200,"_DA(1)_",""PS1"",",DIC(0)="QEAL"
- D ^DIC I Y=-1 K DIC,DA G STATQ
- F Z=1:1:3 L +^VA(200,IBDA):5 Q:$T
- I '$T D G STATQ
- . W !,"Another user is editing this entry. Try again later"
- . S DIR(0)="EA",DIR("A")="Press enter to continue"
- . W ! D ^DIR K DIR W !
- S DIE=DIC K DIC S DA=+Y,DR=".01;1"
- D ^DIE K DIE,DR,DA,Y
- L -^VA(200,IBDA)
- STATQ ;
- S VALMBCK="R"
- Q
- ;
- GETLIC(IBPRV) ; Get license # for provider in file 200 IBPRV
- ; Pass IBPRV by reference to retrieve #'s by state
- ; IBPRV(state ien)=id
- ; Returns 0 if no license # found
- N Z
- S Z=0 F S Z=$O(^VA(200,IBPRV,"PS1",Z)) Q:'Z S Z0=$G(^(Z,0)) I $P(Z0,U,2)'="" S IBPRV(+Z0)=$P(Z0,U,2)
- Q +$O(IBPRV(0))
- ;
- EDIT(IBFILE,IBFLD,IB0,IBOLD,IBIEN,IBCK1) ; Generic edit flds
- N DIR,Y,X,IB,IB1,IBCUVAL,IBCUY,IBFLD0,IBNEW,IBPRV,IBVAL,IBIVAL,IBINS,IBCUCHK,IBOK,DUOUT,DTOUT
- I IBFILE=355.91,IBFLD=.02 S IBNEW="" G EDITQ ; No .02 in file 355.91
- S IBCUCHK=1,IBCUVAL=""
- S IBFLD0=IBFLD*100,IBPRV=$S(IBFILE=355.9:$P(IB0,U),1:""),IBNEW=""
- S IBPRV0=$S(IBPRV'["355.93":"",1:$G(^IBA(355.93,+IBPRV,0)))
- S IBINS=$P(IB0,U,$S(IBFILE=355.9:2,1:1))
- I IBFLD'=.03 S IBVAL=$$EXPAND^IBTRE(IBFILE,IBFLD,$P(IB0,U,IBFLD0)),IBIVAL=$P(IB0,U,IBFLD0)
- I IBFLD=.03,$S('IBINS:1,1:'$$CAREUN^IBCEP3(IBINS,$P(IB0,U,6),$P(IB0,U,4),$P(IB0,U,5),$P(IB0,U,5)=3)) S:$P(IB0,U,3) IBNEW="@" G EDITQ
- I IBFLD=.03 S IBVAL=$P($G(^IBA(355.95,+$G(^IBA(355.96,+$P(IB0,U,3),0)),0)),U),IBIVAL=$P(IB0,U,3) D
- . S IBCUCHK=0,IBCUVAL=$P($G(^IBA(355.96,+IBIVAL,0)),U,1) I IBCUVAL="" Q
- . I $O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,$P(IB0,U,4),$P(IB0,U,5),$P(IB0,U,6),"")) S IBCUCHK=1 Q
- . I $O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,$P(IB0,U,4),0,$P(IB0,U,6),"")) S IBCUCHK=1 Q
- . I $O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,$P(IB0,U,5),$P(IB0,U,6),"")) S IBCUCHK=1 Q
- . I $O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,0,$P(IB0,U,6),"")) S IBCUCHK=1 Q
- . S IBIVAL="@"
- ;
- I IBFLD'=.02 D
- . N DA
- . S DIR(0)=$S(IBFLD'=.03:IBFILE_","_IBFLD_"AO",1:"PAO^355.95:AEMQ")
- . I IBFLD=.03 D Q:$P(IB0,U,4)=""!($P(IB0,U,5)="")!($P(IB0,U,6)="")
- .. S DIR("A")="CARE UNIT: "
- .. S DIR("S")="I $D(^IBA(355.96,""AUNIQ"",IBINS,Y,$P(IB0,U,4),$P(IB0,U,5),$P(IB0,U,6)))!($D(^IBA(355.96,""AUNIQ"",IBINS,Y,$P(IB0,U,4),0,$P(IB0,U,6))))"
- .. S DIR("S")=DIR("S")_"!($D(^IBA(355.96,""AUNIQ"",IBINS,Y,0,$P(IB0,U,5),$P(IB0,U,6))))!($D(^IBA(355.96,""AUNIQ"",IBINS,Y,0,0,$P(IB0,U,6))))"
- . I IBFLD'=.03 S DIR("A")=$$GET1^DID(IBFILE,IBFLD,,"LABEL")_": "
- . S:IBVAL'=""&(IBCUCHK) DIR("A")=DIR("A")_IBVAL_"// "
- .; If field .04, Set DIR(0)[3] up to make sure the form type selected is allowed for this ID type.
- . I Z=.04,IBPRV["355.93",$$GET1^DIQ(355.93,+IBPRV,.02,"I")=1 D
- .. I $$GET1^DIQ(355.97,$P(IB0,U,6),.03,"I")="EI" S $P(DIR(0),U,3)="K:Y'=1 X",DIR("?")="Provider ID Qualifier selected only allows institutional (UB type) forms" Q
- .. I $$GET1^DIQ(355.97,$P(IB0,U,6),.03,"I")="TJ" S $P(DIR(0),U,3)="K:Y'=2 X",DIR("?")="Provider ID Qualifier selected only allows professional (CMS-1500) forms" Q
- .. N AFT
- .. S AFT=$$GET1^DIQ(355.97,$P(IB0,U,6),.07,"I") ; get allowable form type for this Provider ID Type
- .. I AFT="B" S $P(DIR(0),U,3)="K:"".0.1.2.""'[("".""_X_""."") X",DIR("?")="Provider ID Qualifier selected allows institutional, professional or both" Q ; allow proff, inst, or both
- .. I AFT="I" S $P(DIR(0),U,3)="K:X'=1 X",DIR("?")="Provider ID Qualifier selected only allows institutional (UB type) forms" Q ; allow institutional
- .. I AFT="P" S $P(DIR(0),U,3)="K:X'=2 X",DIR("?")="Provider ID Qualifier selected only allows professional (CMS-1500) forms" Q ; allow professional
- . ;
- . ; field .06 (ID qualifier)
- . I Z=.06 D ;,IBPRV["355.93" D
- .. S DIR(0)="PAOr^355.97:AEMQ"
- .. ;JWS'IB*2.0*592 - corrected spelling error
- .. S DIR("?")="Enter a Qualifier to identify the type of ID number you are entering."
- .. N TAG
- .. S TAG=$S($G(IBSLEV)=1&($$GET1^DIQ(355.93,+IBPRV,.02,"I")=1):"NVALFOWN",$G(IBSLEV)=1:"RAOWN",$$GET1^DIQ(355.93,+IBPRV,.02,"I")=1:"LFINS",1:"RAINS")
- .. N AFT
- .. S AFT=$S($P(IB0,U,4)]"":$P(IB0,U,4),1:$P(IBOLD,U,4))
- .. D
- ... I AFT=1 S DIR("S")="I $$"_TAG_"^IBCEPU(Y),$$GET1^DIQ(355.97,+Y,.07,""I"")'=""P""",DIR("?")="Provider ID Qualifier selected only allows institutional (UB type) forms" Q
- ... I AFT=2 S DIR("S")="I $$"_TAG_"^IBCEPU(Y),$$GET1^DIQ(355.97,+Y,.07,""I"")'=""I""",DIR("?")="Provider ID Qualifier selected only allows professional (CMS-1500) forms" Q
- ... S DIR("S")="I $$"_TAG_"^IBCEPU(Y)"
- .. I $$GET1^DIQ(355.93,+IBPRV,.02,"I")=1 D
- ... I AFT=1 S DIR("S")=DIR("S")_",$$GET1^DIQ(355.97,+Y,.03)'=""TJ""" Q
- ... I AFT=2 S DIR("S")=DIR("S")_",$$GET1^DIQ(355.97,+Y,.03)'=""EI""" Q
- ... I 'AFT S DIR("S")=DIR("S")_","".EI.TJ.""'[("".""_$$GET1^DIQ(355.97,+Y,.03)_""."")" Q
- . ;
- . S DA=0
- . F D ^DIR S IBOK=0 D Q:IBOK
- .. I $D(DUOUT)!$D(DTOUT) S IBOK=1 Q
- .. I X="",$P(IB0,U,(IBFLD*100))'="" S (X,Y)=$P(IB0,U,(IBFLD*100))
- .. I IBFLD=.06,$P(IB0,U,4)'=1,$P($G(^IBE(355.97,$S(+Y:+Y,1:+$P(IB0,U,6)),0)),U,3)="1A" W !,"BLUE CROSS IS ONLY ALLOWED FOR UB-04 ONLY" Q
- .. S IBOK=1
- . K DIR
- . I IBFLD=.03,'$D(DTOUT),'$D(DUOUT) D S Y=IBCUY
- .. S IBCUVAL=+$G(^IBA(355.96,+Y,0))
- .. S IBCUY=+$O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,$P(IB0,U,4),$P(IB0,U,5),$P(IB0,U,6),0))
- .. I 'IBCUY S IBCUY=+$O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,$P(IB0,U,4),0,$P(IB0,U,6),0))
- .. I 'IBCUY S IBCUY=+$O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,$P(IB0,U,5),$P(IB0,U,6),0))
- .. I 'IBCUY S IBCUY=+$O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,0,$P(IB0,U,6),0))
- .. I 'IBCUY S IBCUY="@"
- . I IBIVAL'="",IBCUCHK,($P(Y,U)=IBIVAL!(X="")) S IBNEW=IBIVAL Q
- . I 'IBCUCHK,X="" S IBNEW=IBIVAL Q
- . I X'="@",($S(X="":IBIVAL'="",1:0)!$D(DTOUT)!$D(DUOUT)) S IBNEW="^1" Q
- . S IBNEW=$S(X'="@":$P(Y,U),1:X)
- . I IBFLD=.03,X="" S IBNEW="" ; No care unit selected
- I IBFLD=.02 D ; Only file 355.9
- . N DIR,X,Y,DIC,DA,IBIT
- . S IBIT=$$GET1^DID(355.9,.02,,"INPUT TRANSFORM")
- . S DIR(0)="FAO^1:30"
- . S DIR("A")="INSURANCE CO: "_$S(IBVAL'="":IBVAL_"// ",1:" "),DIR("?")="^N IBHELP,Z D HELP^DIE(355.9,,.02,""A"",""IBHELP"") S Z=0 F S Z=$O(IBHELP(""DIHELP"",Z)) Q:'Z W !,IBHELP(""DIHELP"",Z)"
- . F W ! D ^DIR D I IBNEW'="" K DIR Q
- .. I $D(DTOUT)!$D(DUOUT) S IBNEW="^1" Q
- .. I IBIVAL'="",($P(Y,U)=IBIVAL!(X="")) S IBNEW=IBIVAL Q
- .. I X="@" S IBNEW="@" Q
- .. I X="",IBIVAL="" S IBNEW="*ALL*" Q
- .. S DIC="^DIC(36,",DIC(0)="EMQ",DIC("S")="X IBIT I $D(X)" D ^DIC
- .. I Y>0 S IBNEW=$P(Y,U) Q
- .. S Y="",IBNEW="^1"
- G:IBNEW="^1"!(IBNEW=IBIVAL)!(IBFLD=.07) EDITQ
- I $G(IBCK1) D
- . N X1,X2,X3,X4,X5,X6
- . S X1=$S(IBFILE=355.9:$S(IBFLD'=.01:IBPRV,1:IBNEW),1:"")
- . S X2=$S(IBFILE=355.9:$S(IBFLD'=.02:$P(IB0,U,2),1:IBNEW),1:$S(IBFLD'=.01:$P(IB0,U),1:IBNEW))
- . S X3=$S(IBFLD'=.03:$P(IB0,U,3),1:IBNEW),X4=$S(IBFLD'=.04:$P(IB0,U,4),1:IBNEW),X5=$S(IBFLD'=.05:$P(IB0,U,5),1:IBNEW),X6=$S(IBFLD'=.06:$P(IB0,U,6),1:IBNEW)
- . I X2="" S X2="*ALL*"
- . I X3="" S X3="*N/A*"
- . I IBFILE=355.9,$S(X4=""!(X5="")!(X6=""):1,$O(^IBA(355.9,"AUNIQ",X1,X2,X3,X4,X5,X6,0)):$O(^(0))'=IBIEN,1:0) S IBNEW=IBNEW_"^2" Q
- . I IBFILE=355.91,$S(X4=""!(X5="")!(X6=""):1,$O(^IBA(355.91,"AUNIQ",X2,X3,X4,X5,X6,0)):$O(^(0))'=IBIEN,1:0) S IBNEW=IBNEW_"^2" Q
- . F IB=2,3 D Q:$P(IBNEW,U,3)=3
- .. S IB1=(X2="*ALL*"!(X3="*N/A*"))
- .. I IBFILE=355.9,IB=2,$S($P(IBOLD,U,2)="":X2'="*ALL*",1:$P(IBOLD,U,2)'=X2) S X2=""
- .. I IB=3,$S($P(IBOLD,U,3)="":X3'="*N/A*",1:$P(IBOLD,U,3)'=X3) S X3=""
- .. I '$$COMBOK^IBCEP5C(IBFILE,IBPRV_U_(IBFLD*100)_U_X2_U_X3_U_X4_U_X5_U_X6,IB1) S IBNEW="^3"
- ;
- EDITQ Q IBNEW
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEP5D 8477 printed Feb 18, 2025@23:38:06 Page 2
- IBCEP5D ;ALB/JEH - EDI UTILITIES - for State License ;29-MAR-01
- +1 ;;2.0;INTEGRATED BILLING;**137,320,348,349,592**;21-MAR-94;Build 58
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ; STATE LICENSE # ADD/EDIT DBIA ==> DBIA 224
- EN ;Add/edit state and license number
- +1 NEW IBDA,DIR,DIC,DD,DA,DR,IBSTAT,IBLIC,IBQ,Y
- +2 DO FULL^VALM1
- +3 IF '$GET(IBPRV)
- Begin DoDot:1
- +4 SET IBQ=0
- +5 SET DIC="^VA(200,"
- SET DIC(0)="AEMQ"
- SET DIC("A")="Select VA Provider: "
- DO ^DIC
- KILL DIC
- +6 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<0)
- SET IBQ=1
- QUIT
- +7 SET IBDA=+Y
- End DoDot:1
- if IBQ
- GOTO STATQ
- +8 IF $GET(IBPRV)["VA"
- SET IBDA=+IBPRV
- +9 IF $GET(IBPRV)
- IF $GET(IBPRV)'["VA"
- Begin DoDot:1
- +10 SET DIR("A",1)="You have selected a Non-VA provider"
- +11 SET DIR("A",2)="State license # can only be entered for VA providers"
- +12 SET DIR("A",3)=""
- +13 SET DIR("A")="Press enter to continue"
- +14 SET DIR(0)="EA"
- WRITE !
- DO ^DIR
- KILL DIR
- WRITE !
- End DoDot:1
- GOTO STATQ
- STALIC ;Add/edit file 200 field 54.1 multiple,state(.01) and license#(1) - DBIA 224
- +1 ;
- +2 SET DA(1)=IBDA
- SET DIC="^VA(200,"_DA(1)_",""PS1"","
- SET DIC(0)="QEAL"
- +3 DO ^DIC
- IF Y=-1
- KILL DIC,DA
- GOTO STATQ
- +4 FOR Z=1:1:3
- LOCK +^VA(200,IBDA):5
- if $TEST
- QUIT
- +5 IF '$TEST
- Begin DoDot:1
- +6 WRITE !,"Another user is editing this entry. Try again later"
- +7 SET DIR(0)="EA"
- SET DIR("A")="Press enter to continue"
- +8 WRITE !
- DO ^DIR
- KILL DIR
- WRITE !
- End DoDot:1
- GOTO STATQ
- +9 SET DIE=DIC
- KILL DIC
- SET DA=+Y
- SET DR=".01;1"
- +10 DO ^DIE
- KILL DIE,DR,DA,Y
- +11 LOCK -^VA(200,IBDA)
- STATQ ;
- +1 SET VALMBCK="R"
- +2 QUIT
- +3 ;
- GETLIC(IBPRV) ; Get license # for provider in file 200 IBPRV
- +1 ; Pass IBPRV by reference to retrieve #'s by state
- +2 ; IBPRV(state ien)=id
- +3 ; Returns 0 if no license # found
- +4 NEW Z
- +5 SET Z=0
- FOR
- SET Z=$ORDER(^VA(200,IBPRV,"PS1",Z))
- if 'Z
- QUIT
- SET Z0=$GET(^(Z,0))
- IF $PIECE(Z0,U,2)'=""
- SET IBPRV(+Z0)=$PIECE(Z0,U,2)
- +6 QUIT +$ORDER(IBPRV(0))
- +7 ;
- EDIT(IBFILE,IBFLD,IB0,IBOLD,IBIEN,IBCK1) ; Generic edit flds
- +1 NEW DIR,Y,X,IB,IB1,IBCUVAL,IBCUY,IBFLD0,IBNEW,IBPRV,IBVAL,IBIVAL,IBINS,IBCUCHK,IBOK,DUOUT,DTOUT
- +2 ; No .02 in file 355.91
- IF IBFILE=355.91
- IF IBFLD=.02
- SET IBNEW=""
- GOTO EDITQ
- +3 SET IBCUCHK=1
- SET IBCUVAL=""
- +4 SET IBFLD0=IBFLD*100
- SET IBPRV=$SELECT(IBFILE=355.9:$PIECE(IB0,U),1:"")
- SET IBNEW=""
- +5 SET IBPRV0=$SELECT(IBPRV'["355.93":"",1:$GET(^IBA(355.93,+IBPRV,0)))
- +6 SET IBINS=$PIECE(IB0,U,$SELECT(IBFILE=355.9:2,1:1))
- +7 IF IBFLD'=.03
- SET IBVAL=$$EXPAND^IBTRE(IBFILE,IBFLD,$PIECE(IB0,U,IBFLD0))
- SET IBIVAL=$PIECE(IB0,U,IBFLD0)
- +8 IF IBFLD=.03
- IF $SELECT('IBINS:1,1:'$$CAREUN^IBCEP3(IBINS,$PIECE(IB0,U,6),$PIECE(IB0,U,4),$PIECE(IB0,U,5),$PIECE(IB0,U,5)=3))
- if $PIECE(IB0,U,3)
- SET IBNEW="@"
- GOTO EDITQ
- +9 IF IBFLD=.03
- SET IBVAL=$PIECE($GET(^IBA(355.95,+$GET(^IBA(355.96,+$PIECE(IB0,U,3),0)),0)),U)
- SET IBIVAL=$PIECE(IB0,U,3)
- Begin DoDot:1
- +10 SET IBCUCHK=0
- SET IBCUVAL=$PIECE($GET(^IBA(355.96,+IBIVAL,0)),U,1)
- IF IBCUVAL=""
- QUIT
- +11 IF $ORDER(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,$PIECE(IB0,U,4),$PIECE(IB0,U,5),$PIECE(IB0,U,6),""))
- SET IBCUCHK=1
- QUIT
- +12 IF $ORDER(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,$PIECE(IB0,U,4),0,$PIECE(IB0,U,6),""))
- SET IBCUCHK=1
- QUIT
- +13 IF $ORDER(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,$PIECE(IB0,U,5),$PIECE(IB0,U,6),""))
- SET IBCUCHK=1
- QUIT
- +14 IF $ORDER(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,0,$PIECE(IB0,U,6),""))
- SET IBCUCHK=1
- QUIT
- +15 SET IBIVAL="@"
- End DoDot:1
- +16 ;
- +17 IF IBFLD'=.02
- Begin DoDot:1
- +18 NEW DA
- +19 SET DIR(0)=$SELECT(IBFLD'=.03:IBFILE_","_IBFLD_"AO",1:"PAO^355.95:AEMQ")
- +20 IF IBFLD=.03
- Begin DoDot:2
- +21 SET DIR("A")="CARE UNIT: "
- +22 SET DIR("S")="I $D(^IBA(355.96,""AUNIQ"",IBINS,Y,$P(IB0,U,4),$P(IB0,U,5),$P(IB0,U,6)))!($D(^IBA(355.96,""AUNIQ"",IBINS,Y,$P(IB0,U,4),0,$P(IB0,U,6))))"
- +23 SET DIR("S")=DIR("S")_"!($D(^IBA(355.96,""AUNIQ"",IBINS,Y,0,$P(IB0,U,5),$P(IB0,U,6))))!($D(^IBA(355.96,""AUNIQ"",IBINS,Y,0,0,$P(IB0,U,6))))"
- End DoDot:2
- if $PIECE(IB0,U,4)=""!($PIECE(IB0,U,5)="")!($PIECE(IB0,U,6)="")
- QUIT
- +24 IF IBFLD'=.03
- SET DIR("A")=$$GET1^DID(IBFILE,IBFLD,,"LABEL")_": "
- +25 if IBVAL'=""&(IBCUCHK)
- SET DIR("A")=DIR("A")_IBVAL_"// "
- +26 ; If field .04, Set DIR(0)[3] up to make sure the form type selected is allowed for this ID type.
- +27 IF Z=.04
- IF IBPRV["355.93"
- IF $$GET1^DIQ(355.93,+IBPRV,.02,"I")=1
- Begin DoDot:2
- +28 IF $$GET1^DIQ(355.97,$PIECE(IB0,U,6),.03,"I")="EI"
- SET $PIECE(DIR(0),U,3)="K:Y'=1 X"
- SET DIR("?")="Provider ID Qualifier selected only allows institutional (UB type) forms"
- QUIT
- +29 IF $$GET1^DIQ(355.97,$PIECE(IB0,U,6),.03,"I")="TJ"
- SET $PIECE(DIR(0),U,3)="K:Y'=2 X"
- SET DIR("?")="Provider ID Qualifier selected only allows professional (CMS-1500) forms"
- QUIT
- +30 NEW AFT
- +31 ; get allowable form type for this Provider ID Type
- SET AFT=$$GET1^DIQ(355.97,$PIECE(IB0,U,6),.07,"I")
- +32 ; allow proff, inst, or both
- IF AFT="B"
- SET $PIECE(DIR(0),U,3)="K:"".0.1.2.""'[("".""_X_""."") X"
- SET DIR("?")="Provider ID Qualifier selected allows institutional, professional or both"
- QUIT
- +33 ; allow institutional
- IF AFT="I"
- SET $PIECE(DIR(0),U,3)="K:X'=1 X"
- SET DIR("?")="Provider ID Qualifier selected only allows institutional (UB type) forms"
- QUIT
- +34 ; allow professional
- IF AFT="P"
- SET $PIECE(DIR(0),U,3)="K:X'=2 X"
- SET DIR("?")="Provider ID Qualifier selected only allows professional (CMS-1500) forms"
- QUIT
- End DoDot:2
- +35 ;
- +36 ; field .06 (ID qualifier)
- +37 ;,IBPRV["355.93" D
- IF Z=.06
- Begin DoDot:2
- +38 SET DIR(0)="PAOr^355.97:AEMQ"
- +39 ;JWS'IB*2.0*592 - corrected spelling error
- +40 SET DIR("?")="Enter a Qualifier to identify the type of ID number you are entering."
- +41 NEW TAG
- +42 SET TAG=$SELECT($GET(IBSLEV)=1&($$GET1^DIQ(355.93,+IBPRV,.02,"I")=1):"NVALFOWN",$GET(IBSLEV)=1:"RAOWN",$$GET1^DIQ(355.93,+IBPRV,.02,"I")=1:"LFINS",1:"RAINS")
- +43 NEW AFT
- +44 SET AFT=$SELECT($PIECE(IB0,U,4)]"":$PIECE(IB0,U,4),1:$PIECE(IBOLD,U,4))
- +45 Begin DoDot:3
- +46 IF AFT=1
- SET DIR("S")="I $$"_TAG_"^IBCEPU(Y),$$GET1^DIQ(355.97,+Y,.07,""I"")'=""P"""
- SET DIR("?")="Provider ID Qualifier selected only allows institutional (UB type) forms"
- QUIT
- +47 IF AFT=2
- SET DIR("S")="I $$"_TAG_"^IBCEPU(Y),$$GET1^DIQ(355.97,+Y,.07,""I"")'=""I"""
- SET DIR("?")="Provider ID Qualifier selected only allows professional (CMS-1500) forms"
- QUIT
- +48 SET DIR("S")="I $$"_TAG_"^IBCEPU(Y)"
- End DoDot:3
- +49 IF $$GET1^DIQ(355.93,+IBPRV,.02,"I")=1
- Begin DoDot:3
- +50 IF AFT=1
- SET DIR("S")=DIR("S")_",$$GET1^DIQ(355.97,+Y,.03)'=""TJ"""
- QUIT
- +51 IF AFT=2
- SET DIR("S")=DIR("S")_",$$GET1^DIQ(355.97,+Y,.03)'=""EI"""
- QUIT
- +52 IF 'AFT
- SET DIR("S")=DIR("S")_","".EI.TJ.""'[("".""_$$GET1^DIQ(355.97,+Y,.03)_""."")"
- QUIT
- End DoDot:3
- End DoDot:2
- +53 ;
- +54 SET DA=0
- +55 FOR
- DO ^DIR
- SET IBOK=0
- Begin DoDot:2
- +56 IF $DATA(DUOUT)!$DATA(DTOUT)
- SET IBOK=1
- QUIT
- +57 IF X=""
- IF $PIECE(IB0,U,(IBFLD*100))'=""
- SET (X,Y)=$PIECE(IB0,U,(IBFLD*100))
- +58 IF IBFLD=.06
- IF $PIECE(IB0,U,4)'=1
- IF $PIECE($GET(^IBE(355.97,$SELECT(+Y:+Y,1:+$PIECE(IB0,U,6)),0)),U,3)="1A"
- WRITE !,"BLUE CROSS IS ONLY ALLOWED FOR UB-04 ONLY"
- QUIT
- +59 SET IBOK=1
- End DoDot:2
- if IBOK
- QUIT
- +60 KILL DIR
- +61 IF IBFLD=.03
- IF '$DATA(DTOUT)
- IF '$DATA(DUOUT)
- Begin DoDot:2
- +62 SET IBCUVAL=+$GET(^IBA(355.96,+Y,0))
- +63 SET IBCUY=+$ORDER(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,$PIECE(IB0,U,4),$PIECE(IB0,U,5),$PIECE(IB0,U,6),0))
- +64 IF 'IBCUY
- SET IBCUY=+$ORDER(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,$PIECE(IB0,U,4),0,$PIECE(IB0,U,6),0))
- +65 IF 'IBCUY
- SET IBCUY=+$ORDER(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,$PIECE(IB0,U,5),$PIECE(IB0,U,6),0))
- +66 IF 'IBCUY
- SET IBCUY=+$ORDER(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,0,$PIECE(IB0,U,6),0))
- +67 IF 'IBCUY
- SET IBCUY="@"
- End DoDot:2
- SET Y=IBCUY
- +68 IF IBIVAL'=""
- IF IBCUCHK
- IF ($PIECE(Y,U)=IBIVAL!(X=""))
- SET IBNEW=IBIVAL
- QUIT
- +69 IF 'IBCUCHK
- IF X=""
- SET IBNEW=IBIVAL
- QUIT
- +70 IF X'="@"
- IF ($SELECT(X="":IBIVAL'="",1:0)!$DATA(DTOUT)!$DATA(DUOUT))
- SET IBNEW="^1"
- QUIT
- +71 SET IBNEW=$SELECT(X'="@":$PIECE(Y,U),1:X)
- +72 ; No care unit selected
- IF IBFLD=.03
- IF X=""
- SET IBNEW=""
- End DoDot:1
- +73 ; Only file 355.9
- IF IBFLD=.02
- Begin DoDot:1
- +74 NEW DIR,X,Y,DIC,DA,IBIT
- +75 SET IBIT=$$GET1^DID(355.9,.02,,"INPUT TRANSFORM")
- +76 SET DIR(0)="FAO^1:30"
- +77 SET DIR("A")="INSURANCE CO: "_$SELECT(IBVAL'="":IBVAL_"// ",1:" ")
- SET DIR("?")="^N IBHELP,Z D HELP^DIE(355.9,,.02,""A"",""IBHELP"") S Z=0 F S Z=$O(IBHELP(""DIHELP"",Z)) Q:'Z W !,IBHELP(""DIHELP"",Z)"
- +78 FOR
- WRITE !
- DO ^DIR
- Begin DoDot:2
- +79 IF $DATA(DTOUT)!$DATA(DUOUT)
- SET IBNEW="^1"
- QUIT
- +80 IF IBIVAL'=""
- IF ($PIECE(Y,U)=IBIVAL!(X=""))
- SET IBNEW=IBIVAL
- QUIT
- +81 IF X="@"
- SET IBNEW="@"
- QUIT
- +82 IF X=""
- IF IBIVAL=""
- SET IBNEW="*ALL*"
- QUIT
- +83 SET DIC="^DIC(36,"
- SET DIC(0)="EMQ"
- SET DIC("S")="X IBIT I $D(X)"
- DO ^DIC
- +84 IF Y>0
- SET IBNEW=$PIECE(Y,U)
- QUIT
- +85 SET Y=""
- SET IBNEW="^1"
- End DoDot:2
- IF IBNEW'=""
- KILL DIR
- QUIT
- End DoDot:1
- +86 if IBNEW="^1"!(IBNEW=IBIVAL)!(IBFLD=.07)
- GOTO EDITQ
- +87 IF $GET(IBCK1)
- Begin DoDot:1
- +88 NEW X1,X2,X3,X4,X5,X6
- +89 SET X1=$SELECT(IBFILE=355.9:$SELECT(IBFLD'=.01:IBPRV,1:IBNEW),1:"")
- +90 SET X2=$SELECT(IBFILE=355.9:$SELECT(IBFLD'=.02:$PIECE(IB0,U,2),1:IBNEW),1:$SELECT(IBFLD'=.01:$PIECE(IB0,U),1:IBNEW))
- +91 SET X3=$SELECT(IBFLD'=.03:$PIECE(IB0,U,3),1:IBNEW)
- SET X4=$SELECT(IBFLD'=.04:$PIECE(IB0,U,4),1:IBNEW)
- SET X5=$SELECT(IBFLD'=.05:$PIECE(IB0,U,5),1:IBNEW)
- SET X6=$SELECT(IBFLD'=.06:$PIECE(IB0,U,6),1:IBNEW)
- +92 IF X2=""
- SET X2="*ALL*"
- +93 IF X3=""
- SET X3="*N/A*"
- +94 IF IBFILE=355.9
- IF $SELECT(X4=""!(X5="")!(X6=""):1,$ORDER(^IBA(355.9,"AUNIQ",X1,X2,X3,X4,X5,X6,0)):$ORDER(^(0))'=IBIEN,1:0)
- SET IBNEW=IBNEW_"^2"
- QUIT
- +95 IF IBFILE=355.91
- IF $SELECT(X4=""!(X5="")!(X6=""):1,$ORDER(^IBA(355.91,"AUNIQ",X2,X3,X4,X5,X6,0)):$ORDER(^(0))'=IBIEN,1:0)
- SET IBNEW=IBNEW_"^2"
- QUIT
- +96 FOR IB=2,3
- Begin DoDot:2
- +97 SET IB1=(X2="*ALL*"!(X3="*N/A*"))
- +98 IF IBFILE=355.9
- IF IB=2
- IF $SELECT($PIECE(IBOLD,U,2)="":X2'="*ALL*",1:$PIECE(IBOLD,U,2)'=X2)
- SET X2=""
- +99 IF IB=3
- IF $SELECT($PIECE(IBOLD,U,3)="":X3'="*N/A*",1:$PIECE(IBOLD,U,3)'=X3)
- SET X3=""
- +100 IF '$$COMBOK^IBCEP5C(IBFILE,IBPRV_U_(IBFLD*100)_U_X2_U_X3_U_X4_U_X5_U_X6,IB1)
- SET IBNEW="^3"
- End DoDot:2
- if $PIECE(IBNEW,U,3)=3
- QUIT
- End DoDot:1
- +101 ;
- EDITQ QUIT IBNEW