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 Dec 13, 2024@02:11:41 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
