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

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

initial load of WorldVistAEHR
File size: 7.1 KB
Line 
1IBCEP5C ;ALB/TMP - EDI UTILITIES for provider ID ;02-NOV-00
2 ;;2.0;INTEGRATED BILLING;**137,239,232,320,348,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5COMBOK(IBFILE,IBDAT,IBALL,IBF) ; Generic ask if conflict, should id rec still
6 ; be added?
7 ; IBFILE = 355.9 or 355.91 for the file being edited
8 ; IBDAT = var ptr prov ien (355.9) ^ pc to check ^
9 ; ins co ien or *ALL* ^ care unit or *N/A* ^
10 ; form type code ^ care type code ^ prov id type ptr
11 ; IBALL = flag:
12 ; 0 = Individual entry selected - check for existing ALL entry
13 ; 1 = 'ALL' selected - check for existing individual ones
14 ; IBF = 1 if deleting from ins co-related options, ""
15 ; from provider-related options
16 ; Returns 1 if ok to continue, 0 if not
17 ;
18 N X,Y,Q,DIR,Z,IBD,IBDD,IBOK,IBSPEC
19 S IBALL=$G(IBALL),IBOK=1
20 S IBD=+$P(IBDAT,U,2),IBDD=$S(IBD=4:5,1:4)
21 F Z=2:1:6 D
22 . I IBD'=Z,$P(IBDAT,U,Z+1)'="" S Z(Z)=$P(IBDAT,U,Z+1) Q
23 . I IBD=Z S IBD(Z)=$P(IBDAT,U,Z+1)
24 K IBSPEC
25 I IBALL D ; Check for specific
26 . N X0,X1
27 . S X1=0
28 . F S X1=$O(^IBA(IBFILE,"AC",$S(IBFILE=355.9:Z(6),1:Z(2)),$S(IBFILE=355.9:Z(2),1:Z(6)),$S(IBFILE=355.9:$P(IBDAT,U),1:Z(3)),X1)) Q:'X1 S X0=$G(^IBA(IBFILE,X1,0)) I $S(IBFILE=355.9:$P(X0,U,3)=Z(3),1:1) D
29 .. I $P(X0,U,IBD)'=IBD(IBD),"12"[$P(X0,U,IBD),($P(X0,U,IBDD)=Z(IBDD)!($P(X0,U,IBDD)=0)!(Z(IBDD)=0&(IBD(IBD)=0))) S X1($P(X0,U,IBD))=X1 Q
30 .. I IBD(IBD)=0,Z(IBDD)=0 S X1(0)=X1
31 . S X0=0 F S X0=$O(X1(X0)) Q:X0="" D
32 .. S IBSPEC=$S($G(IBSPEC)'="":IBSPEC_" ",1:"")_$P($S(IBD=4:"UB-04^CMS-1500",1:"INPT^OUTPT"),U,X0)_" ONLY"
33 . I $D(X1(0)) S IBSPEC=$S($G(IBSPEC)'="":IBSPEC_" ",1:"")_$S(IBD=4:"BOTH UB-04 and CMS-1500 form type AND BOTH INPT and OUTPT care type",1:"BOTH INPT and OUTPT care type AND BOTH UB-04 and CMS-1500 form type")
34 . ;
35 I 'IBALL D
36 . N X0,X1
37 . S X1=0
38 . F S X1=$O(^IBA(IBFILE,"AC",$S(IBFILE=355.9:Z(6),1:Z(2)),$S(IBFILE=355.9:Z(2),1:Z(6)),$S(IBFILE=355.9:$P(IBDAT,U),1:Z(3)),X1)) Q:'X1 D
39 .. S X0=$G(^IBA(IBFILE,X1,0))
40 .. I $S(IBFILE=355.9:$P(X0,U,16)=Z(3),1:1),$P(X0,U,IBD)=0,$S($P(X0,U,IBDD)=Z(IBDD):1,1:$P(X0,U,IBDD)=0) S IBSPEC=""
41 ;
42 I $D(IBSPEC) D
43 . N X0,X1,TEXT,IBWHAT
44 . S IBWHAT=$S(IBFILE=355.9:$S($G(IBF):"INS CO AND PROVIDER",1:"PROVIDER"),1:"INSURANCE CO")
45 . S X0=$S($D(IBD(4)):"UB-04^CMS-1500",1:"INPT^OUTPT")
46 . S X1=$S($D(IBD(4)):"FORM TYPE",1:"CARE TYPE")
47 . S DIR(0)="YA"
48 . S TEXT(1)="WARNING ... POTENTIAL CONFLICT DETECTED!!"
49 . S TEXT(2)=" YOUR NEW COMBINATION APPLIES TO "_$S(IBALL:"BOTH "_$S(IBD=4:"FORM ",1:"INPT AND OUTPT CARE ")_"TYPES",1:"ONLY "_$P(X0,U,IBD(IBD))_" "_X1)
50 . S TEXT(3)=" THIS SAME COMBINATION ALREADY EXISTS FOR THE "_IBWHAT_" & "_$S('IBALL:"ALL "_X1_"S",1:"SPECIFIC "_X1_"(S):")
51 . S:IBSPEC'="" TEXT(4)=$J("",4)_IBSPEC
52 . S TEXT($S($D(TEXT(4)):5,1:4))=" "
53 . S DIR("A")="ARE YOU SURE YOU STILL WANT TO ADD THIS RECORD?: "
54 . S DIR("?",1)=" "
55 . S DIR("?",2)="This combination appears to be conflicting with one(s) already on file."
56 . S DIR("?",3)="It has already been defined for the "_$$LOW^XLFSTR(IBWHAT)_" for "_$S(IBALL:"at least 1 specific ",1:"ALL ")_$S(IBD=4:"form",1:"care")_" type"_$S(IBALL:".",1:"s.")
57 . S DIR("?")="Respond NO to reject this conflicting record or YES to continue on to add it in spite of the apparent conflict.",DIR("B")="NO"
58 . W !! F Q=1:1 Q:'$D(TEXT(Q)) W TEXT(Q),!
59 . D ^DIR K DIR W !
60 . S IBOK=(Y=1)
61 Q IBOK
62 ;
63CAREUN ;Called from NEWID^IBCEP5B to check for existing record combination
64 N DIR
65 I IBFILE'=355.9 D
66 . S IB35591(.03)=IB3559(.03)
67 . I "0"[IB35591(.03) S IB35591(.03)="*N/A*"
68 . I IB35591(.03)'="*N/A*" S IB35591(.03)=$O(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),IB3559(.04),IB3559(.05),IBPTYP,"")) I 'IB35591(.03) D
69 .. S IB35591(.03)=$O(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),IB3559(.04),0,IBPTYP,"")) I 'IB35591(.03) D
70 ... S IB35591(.03)=$O(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),0,IB3559(.05),IBPTYP,"")) I 'IB35591(.03) D
71 .... S IB35591(.03)=$O(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),0,0,IBPTYP,""))
72 . I $D(^IBA(355.91,"AUNIQ",IBINS,IB35591(.03),IB3559(.04),IB3559(.05),IBPTYP)) D Q
73 .. S DIR(0)="EA",DIR("A",1)="This record already exists - NOT ADDED",DIR("A")="PRESS the ENTER key to continue" W ! D ^DIR K DIR,IB3559,IB35591 W !
74 I IBFILE=355.9 D
75 . S IB35591(.03)=IB3559(.03)
76 . I "0"[IB35591(.03) S IB35591(.03)="*N/A*"
77 . I IB35591(.03)'="*N/A*" S IB35591(.03)=$O(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),IB3559(.04),IB3559(.05),IBPTYP,"")) I 'IB35591(.03) D
78 .. S IB35591(.03)=$O(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),IB3559(.04),0,IBPTYP,"")) I 'IB35591(.03) D
79 ... S IB35591(.03)=$O(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),0,IB3559(.05),IBPTYP,"")) I 'IB35591(.03) D
80 .... S IB35591(.03)=$O(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),0,0,IBPTYP,""))
81 . I $D(^IBA(355.9,"AUNIQ",IBPRV,IBINS,IB35591(.03),IB3559(.04),IB3559(.05),IBPTYP)) D Q
82 .. S DIR(0)="EA",DIR("A",1)="This record already exists - NOT ADDED",DIR("A")="PRESS the ENTER key to continue" W ! D ^DIR K DIR,IB3559,IB35591 W !
83 Q
84 ;
85DEL(IBFILE,IBDA,IBF) ; Delete prov specific ID's
86 ; IBFILE = 355.9 or 355.91 for the file
87 ; IBDA = ien of entry in file IBFILE
88 ; IBF = 1 if deleting from ins co-related options, ""
89 ; from prov-related options
90 N IB0,IBLAST,IBX,DIK,DA,DIR,X,Y,Z
91 F Z=1:1:3 L +^IBA(IBFILE,IBDA):5 Q:$T
92 I '$T D G DELQ
93 . W !,"RECORD IS LOCKED BY ANOTHER USER - TRY AGAIN LATER"
94 . D ENTER^IBCEP5B(.DIR)
95 . W ! D ^DIR K DIR W !
96 S IB0=$G(^IBA(IBFILE,IBDA,0))
97 S IBX=0
98 S IBX=IBX+1,DIR("A",IBX)=" PROVIDER: "_$S(IBFILE=355.9:$$EXPAND^IBTRE(355.9,.01,$P(IB0,U)),1:"*ALL*")
99 D DISP^IBCEP4("DIR(""A"")",$P(IB0,U,$S(IBFILE=355.9:2,1:1)),$P(IB0,U,6),$P(IB0,U,4),$P(IB0,U,5),IBX+1,.IBLAST)
100 I $P(IB0,U,3)'="" S DIR("A",IBLAST+1)="CARE UNIT: "_$$EXPAND^IBTRE(355.91,.03,$P(IB0,U,3))
101 S DIR("A",IBLAST+2)=" PROV ID: "_$P(IB0,U,7),DIR("A",IBLAST+3)=" "
102 S DIR("A")="OK TO DELETE THIS "_$S($G(IBF):"INSURANCE COMPANY ",1:"")_"PROVIDER ID RECORD?: ",DIR("B")="NO"
103 S DIR(0)="YA"
104 W ! D ^DIR K DIR W !
105 I Y'=1 G DELQ
106 I IBDA>0 D
107 . I IBFILE=355.91!(IBFILE=355.9&($P($G(^IBA(IBFILE,IBDA,0)),U)["VA(200,")) D
108 .. N NEXTONE S NEXTONE=$$NEXTONE^IBCEP5A()
109 .. S ^TMP("IB_EDITED_IDS",$J,NEXTONE)=IBDA_U_"DEL"_U_IBFILE_U_IBDA
110 .. S ^TMP("IB_EDITED_IDS",$J,NEXTONE,0)=$G(^IBA(IBFILE,IBDA,0))
111 . S DA=IBDA,DIK="^IBA("_IBFILE_"," D ^DIK
112DELQ L -^IBA(IBFILE,IBDA)
113 Q
114 ;
115CUCHK(IBDA,IB0) ;Called from CHG^IBCEP5B to check for existing combination
116 ; during edit
117 ; IBDA = the ien of the record being edited
118 ; IB0 = Proposed changed 0 node of the entry in the file
119 ; FUNCTION RETURNS 0 if no duplicate found, 1 if record already exists
120 N Z,IBCUCHK,DIR,X,Y
121 S IBCUCHK=0
122 I IBFILE=355.91 S Z=+$O(^IBA(355.91,"AUNIQ",$P(IB0,U,1),$S($P(IB0,U,3)="@":"*N/A*",$P(IB0,U,3):$P(IB0,U,3),1:$P(IB0,U,10)),$P(IB0,U,4),$P(IB0,U,5),$P(IB0,U,6),0)) I Z,Z'=IBDA S IBCUCHK=1
123 I IBFILE=355.9 D
124 . N X,X1
125 . S X=$S($P(IB0,U,2):$P(IB0,U,2),1:$P(IB0,U,15)) S:X="" X="*ALL*"
126 . S X1=$S($P(IB0,U,3):$P(IB0,U,3),$P(IB0,U,3)="@":"",1:$P(IB0,U,16)) S:X1="" X1="*N/A*"
127 . S Z=+$O(^IBA(355.9,"AUNIQ",$P(IB0,U,1),X,X1,$P(IB0,U,4),$P(IB0,U,5),$P(IB0,U,6),0)) I Z,Z'=IBDA S IBCUCHK=1
128 I IBCUCHK D
129 . S DIR(0)="EA",DIR("A",1)="This combination already exists - RECORD NOT CHANGED",DIR("A")="PRESS the ENTER key to continue" W ! D ^DIR K DIR W !
130 Q IBCUCHK
131 ;
Note: See TracBrowser for help on using the repository browser.