Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCEP5D

IBCEP5D.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ; STATE LICENSE # ADD/EDIT DBIA ==> DBIA 224
  1. EN ;Add/edit state and license number
  1. N IBDA,DIR,DIC,DD,DA,DR,IBSTAT,IBLIC,IBQ,Y
  1. D FULL^VALM1
  1. I '$G(IBPRV) D G:IBQ STATQ
  1. . S IBQ=0
  1. . S DIC="^VA(200,",DIC(0)="AEMQ",DIC("A")="Select VA Provider: " D ^DIC K DIC
  1. . I $D(DTOUT)!$D(DUOUT)!(Y<0) S IBQ=1 Q
  1. . S IBDA=+Y
  1. I $G(IBPRV)["VA" S IBDA=+IBPRV
  1. I $G(IBPRV),$G(IBPRV)'["VA" D G STATQ
  1. . S DIR("A",1)="You have selected a Non-VA provider"
  1. . S DIR("A",2)="State license # can only be entered for VA providers"
  1. . S DIR("A",3)=""
  1. . S DIR("A")="Press enter to continue"
  1. . S DIR(0)="EA" W ! D ^DIR K DIR W !
  1. STALIC ;Add/edit file 200 field 54.1 multiple,state(.01) and license#(1) - DBIA 224
  1. ;
  1. S DA(1)=IBDA,DIC="^VA(200,"_DA(1)_",""PS1"",",DIC(0)="QEAL"
  1. D ^DIC I Y=-1 K DIC,DA G STATQ
  1. F Z=1:1:3 L +^VA(200,IBDA):5 Q:$T
  1. I '$T D G STATQ
  1. . W !,"Another user is editing this entry. Try again later"
  1. . S DIR(0)="EA",DIR("A")="Press enter to continue"
  1. . W ! D ^DIR K DIR W !
  1. S DIE=DIC K DIC S DA=+Y,DR=".01;1"
  1. D ^DIE K DIE,DR,DA,Y
  1. L -^VA(200,IBDA)
  1. STATQ ;
  1. S VALMBCK="R"
  1. Q
  1. ;
  1. GETLIC(IBPRV) ; Get license # for provider in file 200 IBPRV
  1. ; Pass IBPRV by reference to retrieve #'s by state
  1. ; IBPRV(state ien)=id
  1. ; Returns 0 if no license # found
  1. N Z
  1. 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)
  1. Q +$O(IBPRV(0))
  1. ;
  1. EDIT(IBFILE,IBFLD,IB0,IBOLD,IBIEN,IBCK1) ; Generic edit flds
  1. N DIR,Y,X,IB,IB1,IBCUVAL,IBCUY,IBFLD0,IBNEW,IBPRV,IBVAL,IBIVAL,IBINS,IBCUCHK,IBOK,DUOUT,DTOUT
  1. I IBFILE=355.91,IBFLD=.02 S IBNEW="" G EDITQ ; No .02 in file 355.91
  1. S IBCUCHK=1,IBCUVAL=""
  1. S IBFLD0=IBFLD*100,IBPRV=$S(IBFILE=355.9:$P(IB0,U),1:""),IBNEW=""
  1. S IBPRV0=$S(IBPRV'["355.93":"",1:$G(^IBA(355.93,+IBPRV,0)))
  1. S IBINS=$P(IB0,U,$S(IBFILE=355.9:2,1:1))
  1. I IBFLD'=.03 S IBVAL=$$EXPAND^IBTRE(IBFILE,IBFLD,$P(IB0,U,IBFLD0)),IBIVAL=$P(IB0,U,IBFLD0)
  1. 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
  1. 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
  1. . S IBCUCHK=0,IBCUVAL=$P($G(^IBA(355.96,+IBIVAL,0)),U,1) I IBCUVAL="" Q
  1. . I $O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,$P(IB0,U,4),$P(IB0,U,5),$P(IB0,U,6),"")) S IBCUCHK=1 Q
  1. . I $O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,$P(IB0,U,4),0,$P(IB0,U,6),"")) S IBCUCHK=1 Q
  1. . I $O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,$P(IB0,U,5),$P(IB0,U,6),"")) S IBCUCHK=1 Q
  1. . I $O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,0,$P(IB0,U,6),"")) S IBCUCHK=1 Q
  1. . S IBIVAL="@"
  1. ;
  1. I IBFLD'=.02 D
  1. . N DA
  1. . S DIR(0)=$S(IBFLD'=.03:IBFILE_","_IBFLD_"AO",1:"PAO^355.95:AEMQ")
  1. . I IBFLD=.03 D Q:$P(IB0,U,4)=""!($P(IB0,U,5)="")!($P(IB0,U,6)="")
  1. .. S DIR("A")="CARE UNIT: "
  1. .. 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))))"
  1. .. 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))))"
  1. . I IBFLD'=.03 S DIR("A")=$$GET1^DID(IBFILE,IBFLD,,"LABEL")_": "
  1. . S:IBVAL'=""&(IBCUCHK) DIR("A")=DIR("A")_IBVAL_"// "
  1. .; If field .04, Set DIR(0)[3] up to make sure the form type selected is allowed for this ID type.
  1. . I Z=.04,IBPRV["355.93",$$GET1^DIQ(355.93,+IBPRV,.02,"I")=1 D
  1. .. 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
  1. .. 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
  1. .. N AFT
  1. .. S AFT=$$GET1^DIQ(355.97,$P(IB0,U,6),.07,"I") ; get allowable form type for this Provider ID Type
  1. .. 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
  1. .. 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
  1. .. 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
  1. . ;
  1. . ; field .06 (ID qualifier)
  1. . I Z=.06 D ;,IBPRV["355.93" D
  1. .. S DIR(0)="PAOr^355.97:AEMQ"
  1. .. ;JWS'IB*2.0*592 - corrected spelling error
  1. .. S DIR("?")="Enter a Qualifier to identify the type of ID number you are entering."
  1. .. N TAG
  1. .. 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")
  1. .. N AFT
  1. .. S AFT=$S($P(IB0,U,4)]"":$P(IB0,U,4),1:$P(IBOLD,U,4))
  1. .. D
  1. ... 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
  1. ... 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
  1. ... S DIR("S")="I $$"_TAG_"^IBCEPU(Y)"
  1. .. I $$GET1^DIQ(355.93,+IBPRV,.02,"I")=1 D
  1. ... I AFT=1 S DIR("S")=DIR("S")_",$$GET1^DIQ(355.97,+Y,.03)'=""TJ""" Q
  1. ... I AFT=2 S DIR("S")=DIR("S")_",$$GET1^DIQ(355.97,+Y,.03)'=""EI""" Q
  1. ... I 'AFT S DIR("S")=DIR("S")_","".EI.TJ.""'[("".""_$$GET1^DIQ(355.97,+Y,.03)_""."")" Q
  1. . ;
  1. . S DA=0
  1. . F D ^DIR S IBOK=0 D Q:IBOK
  1. .. I $D(DUOUT)!$D(DTOUT) S IBOK=1 Q
  1. .. I X="",$P(IB0,U,(IBFLD*100))'="" S (X,Y)=$P(IB0,U,(IBFLD*100))
  1. .. 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
  1. .. S IBOK=1
  1. . K DIR
  1. . I IBFLD=.03,'$D(DTOUT),'$D(DUOUT) D S Y=IBCUY
  1. .. S IBCUVAL=+$G(^IBA(355.96,+Y,0))
  1. .. S IBCUY=+$O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,$P(IB0,U,4),$P(IB0,U,5),$P(IB0,U,6),0))
  1. .. I 'IBCUY S IBCUY=+$O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,$P(IB0,U,4),0,$P(IB0,U,6),0))
  1. .. I 'IBCUY S IBCUY=+$O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,$P(IB0,U,5),$P(IB0,U,6),0))
  1. .. I 'IBCUY S IBCUY=+$O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,0,$P(IB0,U,6),0))
  1. .. I 'IBCUY S IBCUY="@"
  1. . I IBIVAL'="",IBCUCHK,($P(Y,U)=IBIVAL!(X="")) S IBNEW=IBIVAL Q
  1. . I 'IBCUCHK,X="" S IBNEW=IBIVAL Q
  1. . I X'="@",($S(X="":IBIVAL'="",1:0)!$D(DTOUT)!$D(DUOUT)) S IBNEW="^1" Q
  1. . S IBNEW=$S(X'="@":$P(Y,U),1:X)
  1. . I IBFLD=.03,X="" S IBNEW="" ; No care unit selected
  1. I IBFLD=.02 D ; Only file 355.9
  1. . N DIR,X,Y,DIC,DA,IBIT
  1. . S IBIT=$$GET1^DID(355.9,.02,,"INPUT TRANSFORM")
  1. . S DIR(0)="FAO^1:30"
  1. . 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)"
  1. . F W ! D ^DIR D I IBNEW'="" K DIR Q
  1. .. I $D(DTOUT)!$D(DUOUT) S IBNEW="^1" Q
  1. .. I IBIVAL'="",($P(Y,U)=IBIVAL!(X="")) S IBNEW=IBIVAL Q
  1. .. I X="@" S IBNEW="@" Q
  1. .. I X="",IBIVAL="" S IBNEW="*ALL*" Q
  1. .. S DIC="^DIC(36,",DIC(0)="EMQ",DIC("S")="X IBIT I $D(X)" D ^DIC
  1. .. I Y>0 S IBNEW=$P(Y,U) Q
  1. .. S Y="",IBNEW="^1"
  1. G:IBNEW="^1"!(IBNEW=IBIVAL)!(IBFLD=.07) EDITQ
  1. I $G(IBCK1) D
  1. . N X1,X2,X3,X4,X5,X6
  1. . S X1=$S(IBFILE=355.9:$S(IBFLD'=.01:IBPRV,1:IBNEW),1:"")
  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))
  1. . 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)
  1. . I X2="" S X2="*ALL*"
  1. . I X3="" S X3="*N/A*"
  1. . 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
  1. . 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
  1. . F IB=2,3 D Q:$P(IBNEW,U,3)=3
  1. .. S IB1=(X2="*ALL*"!(X3="*N/A*"))
  1. .. I IBFILE=355.9,IB=2,$S($P(IBOLD,U,2)="":X2'="*ALL*",1:$P(IBOLD,U,2)'=X2) S X2=""
  1. .. I IB=3,$S($P(IBOLD,U,3)="":X3'="*N/A*",1:$P(IBOLD,U,3)'=X3) S X3=""
  1. .. I '$$COMBOK^IBCEP5C(IBFILE,IBPRV_U_(IBFLD*100)_U_X2_U_X3_U_X4_U_X5_U_X6,IB1) S IBNEW="^3"
  1. ;
  1. EDITQ Q IBNEW