source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP5D.m@ 1358

Last change on this file since 1358 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 8.1 KB
Line 
1IBCEP5D ;ALB/JEH - EDI UTILITIES - for State License ;29-MAR-01
2 ;;2.0;INTEGRATED BILLING;**137,320,348,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ; STATE LICENSE # ADD/EDIT DBIA ==> DBIA 224
6EN ;Add/edit state and license number
7 N IBDA,DIR,DIC,DD,DA,DR,IBSTAT,IBLIC,IBQ,Y
8 D FULL^VALM1
9 I '$G(IBPRV) D G:IBQ STATQ
10 . S IBQ=0
11 . S DIC="^VA(200,",DIC(0)="AEMQ",DIC("A")="Select VA Provider: " D ^DIC K DIC
12 . I $D(DTOUT)!$D(DUOUT)!(Y<0) S IBQ=1 Q
13 . S IBDA=+Y
14 I $G(IBPRV)["VA" S IBDA=+IBPRV
15 I $G(IBPRV),$G(IBPRV)'["VA" D G STATQ
16 . S DIR("A",1)="You have selected a Non-VA provider"
17 . S DIR("A",2)="State license # can only be entered for VA providers"
18 . S DIR("A",3)=""
19 . S DIR("A")="Press enter to continue"
20 . S DIR(0)="EA" W ! D ^DIR K DIR W !
21STALIC ;Add/edit file 200 field 54.1 multiple,state(.01) and license#(1) - DBIA 224
22 ;
23 S DA(1)=IBDA,DIC="^VA(200,"_DA(1)_",""PS1"",",DIC(0)="QEAL"
24 D ^DIC I Y=-1 K DIC,DA G STATQ
25 F Z=1:1:3 L +^VA(200,IBDA):5 Q:$T
26 I '$T D G STATQ
27 . W !,"Another user is editing this entry. Try again later"
28 . S DIR(0)="EA",DIR("A")="Press enter to continue"
29 . W ! D ^DIR K DIR W !
30 S DIE=DIC K DIC S DA=+Y,DR=".01;1"
31 D ^DIE K DIE,DR,DA,Y
32 L -^VA(200,IBDA)
33STATQ ;
34 S VALMBCK="R"
35 Q
36 ;
37GETLIC(IBPRV) ; Get license # for provider in file 200 IBPRV
38 ; Pass IBPRV by reference to retrieve #'s by state
39 ; IBPRV(state ien)=id
40 ; Returns 0 if no license # found
41 N Z
42 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)
43 Q +$O(IBPRV(0))
44 ;
45EDIT(IBFILE,IBFLD,IB0,IBOLD,IBIEN,IBCK1) ; Generic edit flds
46 N DIR,Y,X,IB,IB1,IBCUVAL,IBCUY,IBFLD0,IBNEW,IBPRV,IBVAL,IBIVAL,IBINS,IBCUCHK,IBOK,DUOUT,DTOUT
47 I IBFILE=355.91,IBFLD=.02 S IBNEW="" G EDITQ ; No .02 in file 355.91
48 S IBCUCHK=1,IBCUVAL=""
49 S IBFLD0=IBFLD*100,IBPRV=$S(IBFILE=355.9:$P(IB0,U),1:""),IBNEW=""
50 S IBPRV0=$S(IBPRV'["355.93":"",1:$G(^IBA(355.93,+IBPRV,0)))
51 S IBINS=$P(IB0,U,$S(IBFILE=355.9:2,1:1))
52 I IBFLD'=.03 S IBVAL=$$EXPAND^IBTRE(IBFILE,IBFLD,$P(IB0,U,IBFLD0)),IBIVAL=$P(IB0,U,IBFLD0)
53 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
54 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
55 . S IBCUCHK=0,IBCUVAL=$P($G(^IBA(355.96,+IBIVAL,0)),U,1) I IBCUVAL="" Q
56 . I $O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,$P(IB0,U,4),$P(IB0,U,5),$P(IB0,U,6),"")) S IBCUCHK=1 Q
57 . I $O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,$P(IB0,U,4),0,$P(IB0,U,6),"")) S IBCUCHK=1 Q
58 . I $O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,$P(IB0,U,5),$P(IB0,U,6),"")) S IBCUCHK=1 Q
59 . I $O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,0,$P(IB0,U,6),"")) S IBCUCHK=1 Q
60 . S IBIVAL="@"
61 ;
62 I IBFLD'=.02 D
63 . N DA
64 . S DIR(0)=$S(IBFLD'=.03:IBFILE_","_IBFLD_"AO",1:"PAO^355.95:AEMQ")
65 . I IBFLD=.03 D Q:$P(IB0,U,4)=""!($P(IB0,U,5)="")!($P(IB0,U,6)="")
66 .. S DIR("A")="CARE UNIT: "
67 .. 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))))"
68 .. 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))))"
69 . I IBFLD'=.03 S DIR("A")=$$GET1^DID(IBFILE,IBFLD,,"LABEL")_": "
70 . S:IBVAL'=""&(IBCUCHK) DIR("A")=DIR("A")_IBVAL_"// "
71 .; If field .04, Set DIR(0)[3] up to make sure the form type selected is allowed for this ID type.
72 . I Z=.04,IBPRV["355.93",$$GET1^DIQ(355.93,+IBPRV,.02,"I")=1 D
73 .. 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
74 .. 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
75 .. N AFT
76 .. S AFT=$$GET1^DIQ(355.97,$P(IB0,U,6),.07,"I") ; get allowable form type for this Provider ID Type
77 .. 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
78 .. 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
79 .. 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
80 . ;
81 . ; field .06 (ID qualifier)
82 . I Z=.06 D ;,IBPRV["355.93" D
83 .. S DIR(0)="PAOr^355.97:AEMQ"
84 .. S DIR("?")="Enter a Qualifier to indentify the type of ID number you are entering."
85 .. N TAG
86 .. 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")
87 .. N AFT
88 .. S AFT=$S($P(IB0,U,4)]"":$P(IB0,U,4),1:$P(IBOLD,U,4))
89 .. D
90 ... 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
91 ... 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
92 ... S DIR("S")="I $$"_TAG_"^IBCEPU(Y)"
93 .. I $$GET1^DIQ(355.93,+IBPRV,.02,"I")=1 D
94 ... I AFT=1 S DIR("S")=DIR("S")_",$$GET1^DIQ(355.97,+Y,.03)'=""TJ""" Q
95 ... I AFT=2 S DIR("S")=DIR("S")_",$$GET1^DIQ(355.97,+Y,.03)'=""EI""" Q
96 ... I 'AFT S DIR("S")=DIR("S")_","".EI.TJ.""'[("".""_$$GET1^DIQ(355.97,+Y,.03)_""."")" Q
97 . ;
98 . S DA=0
99 . F D ^DIR S IBOK=0 D Q:IBOK
100 .. I $D(DUOUT)!$D(DTOUT) S IBOK=1 Q
101 .. I X="",$P(IB0,U,(IBFLD*100))'="" S (X,Y)=$P(IB0,U,(IBFLD*100))
102 .. 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
103 .. S IBOK=1
104 . K DIR
105 . I IBFLD=.03,'$D(DTOUT),'$D(DUOUT) D S Y=IBCUY
106 .. S IBCUVAL=+$G(^IBA(355.96,+Y,0))
107 .. S IBCUY=+$O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,$P(IB0,U,4),$P(IB0,U,5),$P(IB0,U,6),0))
108 .. I 'IBCUY S IBCUY=+$O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,$P(IB0,U,4),0,$P(IB0,U,6),0))
109 .. I 'IBCUY S IBCUY=+$O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,$P(IB0,U,5),$P(IB0,U,6),0))
110 .. I 'IBCUY S IBCUY=+$O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,0,$P(IB0,U,6),0))
111 .. I 'IBCUY S IBCUY="@"
112 . I IBIVAL'="",IBCUCHK,($P(Y,U)=IBIVAL!(X="")) S IBNEW=IBIVAL Q
113 . I 'IBCUCHK,X="" S IBNEW=IBIVAL Q
114 . I X'="@",($S(X="":IBIVAL'="",1:0)!$D(DTOUT)!$D(DUOUT)) S IBNEW="^1" Q
115 . S IBNEW=$S(X'="@":$P(Y,U),1:X)
116 . I IBFLD=.03,X="" S IBNEW="" ; No care unit selected
117 I IBFLD=.02 D ; Only file 355.9
118 . N DIR,X,Y,DIC,DA,IBIT
119 . S IBIT=$$GET1^DID(355.9,.02,,"INPUT TRANSFORM")
120 . S DIR(0)="FAO^1:30"
121 . 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)"
122 . F W ! D ^DIR D I IBNEW'="" K DIR Q
123 .. I $D(DTOUT)!$D(DUOUT) S IBNEW="^1" Q
124 .. I IBIVAL'="",($P(Y,U)=IBIVAL!(X="")) S IBNEW=IBIVAL Q
125 .. I X="@" S IBNEW="@" Q
126 .. I X="",IBIVAL="" S IBNEW="*ALL*" Q
127 .. S DIC="^DIC(36,",DIC(0)="EMQ",DIC("S")="X IBIT I $D(X)" D ^DIC
128 .. I Y>0 S IBNEW=$P(Y,U) Q
129 .. S Y="",IBNEW="^1"
130 G:IBNEW="^1"!(IBNEW=IBIVAL)!(IBFLD=.07) EDITQ
131 I $G(IBCK1) D
132 . N X1,X2,X3,X4,X5,X6
133 . S X1=$S(IBFILE=355.9:$S(IBFLD'=.01:IBPRV,1:IBNEW),1:"")
134 . S X2=$S(IBFILE=355.9:$S(IBFLD'=.02:$P(IB0,U,2),1:IBNEW),1:$S(IBFLD'=.01:$P(IB0,U),1:IBNEW))
135 . 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)
136 . I X2="" S X2="*ALL*"
137 . I X3="" S X3="*N/A*"
138 . 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
139 . 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
140 . F IB=2,3 D Q:$P(IBNEW,U,3)=3
141 .. S IB1=(X2="*ALL*"!(X3="*N/A*"))
142 .. I IBFILE=355.9,IB=2,$S($P(IBOLD,U,2)="":X2'="*ALL*",1:$P(IBOLD,U,2)'=X2) S X2=""
143 .. I IB=3,$S($P(IBOLD,U,3)="":X3'="*N/A*",1:$P(IBOLD,U,3)'=X3) S X3=""
144 .. I '$$COMBOK^IBCEP5C(IBFILE,IBPRV_U_(IBFLD*100)_U_X2_U_X3_U_X4_U_X5_U_X6,IB1) S IBNEW="^3"
145 ;
146EDITQ Q IBNEW
Note: See TracBrowser for help on using the repository browser.