- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEFG1.m
r613 r623 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,371,377**;21-MAR-94;Build 23 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 AMT=$TR(AMT,","),DOLR=$P(AMT,"."),CENT=$E($P(AMT,".",2)_"00",1,2),AMT=DOLR_CENT 89 Q 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 EMPLST(CODE) ;Return the X12 code for employment status 99 ; CODE = DHCP code for employment status 100 N X12 101 S X12="" 102 S:CODE'="" X12=$P($P("1;FT^2;PT^3;NE^4;SE^5;RT^6;AU^9;UK",CODE_";",2),U) 103 S:X12="" X12="UK" 104 Q X12 105 ; 106 MARITAL(CODE) ;Return the X12 code for marital status 107 ; CODE = ien of code for marital status 108 N X12 109 S X12=$P($G(^DIC(11,+CODE,0)),U,3) 110 I X12'="" S X12=$P($P("D;D^M;M^N;I^S;X^W;W^U;K",X12_";",2),U) 111 Q X12 112 ; 113 TOS(CODE) ;Return the X12 code for type of service 114 ; CODE = DHCP code for type of service 115 N X12 116 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 117 Q X12 118 ; 119 FIXLEN(DATA,LEN) ; Create a fixed length field from data DATA length LEN 120 Q $E(DATA_$J("",LEN),1,LEN) 121 ; 122 RCDT(IBXSAVE,IBXDATA,IBDT) ; Format date for multiple revenue code transmission) 123 ;IBXSAVE = array containing the extracted service line data for the UB format bill 124 ;IBXDATA = array returned with service line dates formatted in YYYYMMDD format 125 ;IBDT = the default date for the revenue codes on the bill 126 N Q,W 127 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) 128 Q 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
Note:
See TracChangeset
for help on using the changeset viewer.
