| [623] | 1 | IBCEFG1 ;ALB/TMP - OUTPUT FORMATTER DATA DEFINITION UTILITIES ;18-JAN-96
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**52,51,137,181,197,232,288,349**;21-MAR-94;Build 46
|
|---|
| 3 | ;;Per VHA Directive 2004-038, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | EDIBILL(IBXFORM,IBXDA,IBINS,IBTYP) ; Find element associated with form fld
|
|---|
| 6 | ; IBXFORM = (REQUIRED) actual form being extracted (in file 353)
|
|---|
| 7 | ; IBXDA = (REQUIRED) form definition file (364.6) entry to use to find
|
|---|
| 8 | ; extract data element definition entry (in file 364.7)
|
|---|
| 9 | ; IBINS = (REQUIRED) insurance co. ien for the current insurance on bill
|
|---|
| 10 | ; IBTYP = (REQUIRED) bill type (I/O)
|
|---|
| 11 | ;
|
|---|
| 12 | ; Returns ien of the entry in file 364.7 if a match on override criteria
|
|---|
| 13 | ; was found. Returns -1 if a screen form and the criteria fails for a
|
|---|
| 14 | ; field without an override
|
|---|
| 15 | ;
|
|---|
| 16 | N IBX,IBPARFM,IBSCREEN,IBNMATCH,EDIQ,IB1
|
|---|
| 17 | I $G(IBXDA)=""!($G(IBXFORM)="") G EDIQ
|
|---|
| 18 | S EDIQ=0
|
|---|
| 19 | S IBPARFM=$P($G(^IBE(353,IBXFORM,2)),U,5) S:'IBPARFM IBPARFM=IBXFORM
|
|---|
| 20 | S IBSCREEN=($P($G(^IBE(353,+IBXFORM,2)),U,2)="S")
|
|---|
| 21 | S IB1=(IBPARFM=IBXFORM) ; Not a local field that is not a parent
|
|---|
| 22 | ;
|
|---|
| 23 | I $G(IBINS)'="",$G(IBTYP)'="" D:$O(^IBA(364.7,"AINTYP",IBXDA,""))'="" G:EDIQ EDIQ
|
|---|
| 24 | . I '$D(^IBA(364.7,"AINTYP",IBXDA,IBINS,IBTYP)) S IBNMATCH=1 Q
|
|---|
| 25 | . S IBX=+$O(^IBA(364.7,"AINTYP",IBXDA,IBINS,IBTYP,"")),EDIQ=1 S:IBX IBNMATCH=0 ;by ins co and type of bill
|
|---|
| 26 | ;
|
|---|
| 27 | I $G(IBINS)'="" D:$O(^IBA(364.7,"AINS",IBXDA,""))'="" G:EDIQ EDIQ
|
|---|
| 28 | . I '$D(^IBA(364.7,"AINS",IBXDA,IBINS)) S IBNMATCH=1 Q
|
|---|
| 29 | . S IBX=+$O(^IBA(364.7,"AINS",IBXDA,IBINS,"")),EDIQ=1 S:IBX IBNMATCH=0 ;ins co only
|
|---|
| 30 | ;
|
|---|
| 31 | I $G(IBTYP)'="" D:$O(^IBA(364.7,"ATYPE",IBXDA,""))'="" G:EDIQ EDIQ
|
|---|
| 32 | . I '$D(^IBA(364.7,"ATYPE",IBXDA,IBTYP)) S IBNMATCH=1 Q
|
|---|
| 33 | . S IBX=+$O(^IBA(364.7,"ATYPE",IBXDA,IBTYP,"")),EDIQ=1 S:IBX IBNMATCH=0 ;type of bill only
|
|---|
| 34 | ;
|
|---|
| 35 | I IBXFORM,$S(IBXFORM'=IBPARFM:1,1:IBSCREEN) D G EDIQ
|
|---|
| 36 | . S IBX=+$O(^IBA(364.7,"ALL",IBXDA,"")) ; Check for all ins co and types
|
|---|
| 37 | . I IBX,+$O(^IBA(364.7,"ALL",IBXDA,IBX)) D ; Find override for 'ALL'
|
|---|
| 38 | .. N Z
|
|---|
| 39 | .. S Z=0 F S Z=$O(^IBA(364.7,"ALL",IBXDA,Z)) Q:'Z I $P($G(^IBA(364.7,Z,0)),U)'=IBXDA S IBX=Z Q
|
|---|
| 40 | . I 'IBX,+$O(^IBA(364.7,"B",IBXDA,"")) S IBX=$O(^(""))
|
|---|
| 41 | . S:IBX IBNMATCH=0
|
|---|
| 42 | ;
|
|---|
| 43 | I IBXFORM,$O(^IBA(364.6,"APAR",IBXFORM,IBXDA,"")) S IBX=+$O(^("")),IBX=+$O(^IBA(364.7,"B",IBX,0)) I IBX G EDIQ
|
|---|
| 44 | S IBX=+$O(^IBA(364.7,"B",IBXDA,""))
|
|---|
| 45 | EDIQ I IBSCREEN,$G(IBNMATCH) S IBX=-1
|
|---|
| 46 | Q $G(IBX)
|
|---|
| 47 | ;
|
|---|
| 48 | DT(DATE1,DATE2,FORMAT) ; Return date in DATE1 (and optionally DATE2)
|
|---|
| 49 | ; (input in Fileman format) converted to X12 format
|
|---|
| 50 | ; FORMAT (required)
|
|---|
| 51 | ; DATE1,DATE2 in FILEMAN date format
|
|---|
| 52 | N DATE S DATE=""
|
|---|
| 53 | I DATE1=0 S DATE1=""
|
|---|
| 54 | I $E(FORMAT)="D" D G DTQ
|
|---|
| 55 | .S DATE=$E(DATE1,2,7) Q:$P(FORMAT,"D",2)=6 ;YYMMDD
|
|---|
| 56 | .S:DATE1 DATE=($E(DATE1)+17)_DATE ;CCYYMMDD
|
|---|
| 57 | I $E(FORMAT)="R" D
|
|---|
| 58 | .S:DATE1 DATE=$E(DATE1,2,7)_"-"_$E($S($G(DATE2):DATE2,1:DATE1),2,7) ;YYMMDD-YYMMDD
|
|---|
| 59 | .Q:FORMAT["6"
|
|---|
| 60 | .S DATE=($E(DATE1)+17)_DATE,$P(DATE,"-",2)=($E($S($G(DATE2):DATE2,1:DATE1))+17)_$P(DATE,"-",2) ;CCYYMMDD-CCYYMMDD
|
|---|
| 61 | DTQ Q DATE
|
|---|
| 62 | ;
|
|---|
| 63 | NAME(IBNM1,COMB) ; Parse person's nm into 5 pieces LAST^FIRST^MIDDLE^CRED^SUFFIX
|
|---|
| 64 | ; IBNM1 = NAME in LAST,FIRST MIDDLE^vp file ien (200 or 355.93)^bill ien^prv type
|
|---|
| 65 | ; OR FIRST MIDDLE LAST^vp file ien (200 or 355.93)^bill ien^prv type
|
|---|
| 66 | ; COMB = if set to 1, then combine the first and middle name
|
|---|
| 67 | ; if set to 2, combine the last and middle names
|
|---|
| 68 | N PC,IBIEN,IBCRED,IBNM,IBNMC,IBPIEN
|
|---|
| 69 | S IBIEN=$P(IBNM1,U,2),IBNMC=$P(IBNM1,U)
|
|---|
| 70 | S IBPIEN=+$O(^DGCR(399,+$P(IBNM1,U,3),"PRV","B",+$P(IBNM1,U,4),0))
|
|---|
| 71 | S IBCRED=$$CRED^IBCEU(IBIEN,+$P(IBNM1,U,3),IBPIEN) ;Degree
|
|---|
| 72 | I IBNMC="DEPT VETERANS AFFAIRS" S IBNMC="VETERANS AFFAIRS,DEPT"
|
|---|
| 73 | I IBNMC["," D G NAMEQ
|
|---|
| 74 | . S IBNMC=$TR(IBNMC,".") D NAMECOMP^XLFNAME(.IBNMC)
|
|---|
| 75 | . S IBNM=$G(IBNMC("FAMILY"))_U_$G(IBNMC("GIVEN"))_U_$G(IBNMC("MIDDLE"))_U_IBCRED_U_$G(IBNMC("SUFFIX"))
|
|---|
| 76 | D STDNAME^XLFNAME(.IBNMC,"C")
|
|---|
| 77 | S IBNM=$G(IBNMC("FAMILY"))_U_$G(IBNMC("GIVEN"))_U_$G(IBNMC("MIDDLE"))_U_IBCRED_U_$G(IBNMC("SUFFIX"))
|
|---|
| 78 | I $P(IBNM1,U,2)["355.93",$P($G(^IBA(355.93,+$P(IBNM1,U,2),0)),U,2)=1 D G NAMEQ ; group performing provider
|
|---|
| 79 | . S IBNM=$P(IBNM1,U)_U_U_U_IBCRED_U
|
|---|
| 80 | I $G(COMB)=1,$G(IBNMC("MIDDLE"))'="" S IBNM=$P(IBNM,U)_U_$P(IBNM,U,2)_" "_$P(IBNM,U,3)_U_IBCRED_U_$P(IBNM,U,5)
|
|---|
| 81 | I $G(COMB)=2,$G(IBNMC("MIDDLE"))'="" S IBNM=$P(IBNM,U)_" "_$P(IBNM,U,3)_U_$P(IBNM,U,2)_U_IBCRED_U_$P(IBNM,U,5)
|
|---|
| 82 | ;
|
|---|
| 83 | NAMEQ Q IBNM
|
|---|
| 84 | ;
|
|---|
| 85 | DOLLAR(AMT) ; Format amount in AMT so it is numeric including cents, without
|
|---|
| 86 | ; the decimal and commas.
|
|---|
| 87 | N DOLR,CENT
|
|---|
| 88 | I AMT'="" S DOLR=$P(AMT,"."),CENT=$E($P(AMT,".",2)_"00",1,2),AMT=DOLR_CENT
|
|---|
| 89 | Q $TR(AMT,",")
|
|---|
| 90 | ;
|
|---|
| 91 | STATE(CODE) ;Return state code from state pointer
|
|---|
| 92 | Q $P($G(^DIC(5,+CODE,0)),U,2)
|
|---|
| 93 | ;
|
|---|
| 94 | SEX(CODE) ;Return the X12 code for sex
|
|---|
| 95 | ; CODE = DHCP code for sex
|
|---|
| 96 | Q $S(CODE="":"U","MF"[$E(CODE):$E(CODE),1:"U")
|
|---|
| 97 | ;
|
|---|
| 98 | RELATION(CODE) ;Return the X12 code for relationship
|
|---|
| 99 | ; CODE = DHCP code for relationship
|
|---|
| 100 | N X12
|
|---|
| 101 | S X12=""
|
|---|
| 102 | S:CODE'="" X12=$P($S(CODE="01":"18^SELF",CODE="02":"01^SPOUSE",CODE="03":"19^NATURAL CHILD",CODE="08":"20^EMPLOYEE",CODE="32":"32^MOTHER",CODE="33":"33^FATHER",CODE="11":"39^ORGAN DONOR",CODE="15":"41^INJURED PLAINTIFF",1:""),U)
|
|---|
| 103 | Q X12
|
|---|
| 104 | ;
|
|---|
| 105 | EMPLST(CODE) ;Return the X12 code for employment status
|
|---|
| 106 | ; CODE = DHCP code for employment status
|
|---|
| 107 | N X12
|
|---|
| 108 | S X12=""
|
|---|
| 109 | S:CODE'="" X12=$P($P("1;FT^2;PT^3;NE^4;SE^5;RT^6;AU^9;UK",CODE_";",2),U)
|
|---|
| 110 | S:X12="" X12="UK"
|
|---|
| 111 | Q X12
|
|---|
| 112 | ;
|
|---|
| 113 | MARITAL(CODE) ;Return the X12 code for marital status
|
|---|
| 114 | ; CODE = ien of code for marital status
|
|---|
| 115 | N X12
|
|---|
| 116 | S X12=$P($G(^DIC(11,+CODE,0)),U,3)
|
|---|
| 117 | I X12'="" S X12=$P($P("D;D^M;M^N;I^S;X^W;W^U;K",X12_";",2),U)
|
|---|
| 118 | Q X12
|
|---|
| 119 | ;
|
|---|
| 120 | TOS(CODE) ;Return the X12 code for type of service
|
|---|
| 121 | ; CODE = DHCP code for type of service
|
|---|
| 122 | N X12
|
|---|
| 123 | S X12=$S(CODE>0&(CODE<10):CODE,1:$P($P("0;10^A;11^B;13^H;45^L;18^M;15^N;63^V;19^Y;20^Z;21^43;96^53;96",CODE_";",2),U)) S:X12="" X12=CODE
|
|---|
| 124 | Q X12
|
|---|
| 125 | ;
|
|---|
| 126 | FIXLEN(DATA,LEN) ; Create a fixed length field from data DATA length LEN
|
|---|
| 127 | Q $E(DATA_$J("",LEN),1,LEN)
|
|---|
| 128 | ;
|
|---|
| 129 | RCDT(IBXSAVE,IBXDATA,IBDT) ; Format date for multiple revenue code transmission)
|
|---|
| 130 | ;IBXSAVE = array containing the extracted service line data for the UB format bill
|
|---|
| 131 | ;IBXDATA = array returned with service line dates formatted in YYYYMMDD format
|
|---|
| 132 | ;IBDT = the default date for the revenue codes on the bill
|
|---|
| 133 | N Q,W
|
|---|
| 134 | S Q=0 F S Q=$O(IBXSAVE("INPT",Q)) Q:'Q S W=$$DT($P(IBXSAVE("INPT",1),U,10),,"D8"),IBXDATA(Q)=$S(W:W,1:IBDT)
|
|---|
| 135 | Q
|
|---|
