- IBCEFG1 ;ALB/TMP - OUTPUT FORMATTER DATA DEFINITION UTILITIES ;18-JAN-96
- ;;2.0;INTEGRATED BILLING;**52,51,137,181,197,232,288,349,371,377,644**;21-MAR-94;Build 4
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- EDIBILL(IBXFORM,IBXDA,IBINS,IBTYP) ; Find element associated with form fld
- ; IBXFORM = (REQUIRED) actual form being extracted (in file 353)
- ; IBXDA = (REQUIRED) form definition file (364.6) entry to use to find
- ; extract data element definition entry (in file 364.7)
- ; IBINS = (REQUIRED) insurance co. ien for the current insurance on bill
- ; IBTYP = (REQUIRED) bill type (I/O)
- ;
- ; Returns ien of the entry in file 364.7 if a match on override criteria
- ; was found. Returns -1 if a screen form and the criteria fails for a
- ; field without an override
- ;
- N IBX,IBPARFM,IBSCREEN,IBNMATCH,EDIQ,IB1
- I $G(IBXDA)=""!($G(IBXFORM)="") G EDIQ
- S EDIQ=0
- S IBPARFM=$P($G(^IBE(353,IBXFORM,2)),U,5) S:'IBPARFM IBPARFM=IBXFORM
- S IBSCREEN=($P($G(^IBE(353,+IBXFORM,2)),U,2)="S")
- S IB1=(IBPARFM=IBXFORM) ; Not a local field that is not a parent
- ;
- I $G(IBINS)'="",$G(IBTYP)'="" D:$O(^IBA(364.7,"AINTYP",IBXDA,""))'="" G:EDIQ EDIQ
- . I '$D(^IBA(364.7,"AINTYP",IBXDA,IBINS,IBTYP)) S IBNMATCH=1 Q
- . S IBX=+$O(^IBA(364.7,"AINTYP",IBXDA,IBINS,IBTYP,"")),EDIQ=1 S:IBX IBNMATCH=0 ;by ins co and type of bill
- ;
- I $G(IBINS)'="" D:$O(^IBA(364.7,"AINS",IBXDA,""))'="" G:EDIQ EDIQ
- . I '$D(^IBA(364.7,"AINS",IBXDA,IBINS)) S IBNMATCH=1 Q
- . S IBX=+$O(^IBA(364.7,"AINS",IBXDA,IBINS,"")),EDIQ=1 S:IBX IBNMATCH=0 ;ins co only
- ;
- I $G(IBTYP)'="" D:$O(^IBA(364.7,"ATYPE",IBXDA,""))'="" G:EDIQ EDIQ
- . I '$D(^IBA(364.7,"ATYPE",IBXDA,IBTYP)) S IBNMATCH=1 Q
- . S IBX=+$O(^IBA(364.7,"ATYPE",IBXDA,IBTYP,"")),EDIQ=1 S:IBX IBNMATCH=0 ;type of bill only
- ;
- I IBXFORM,$S(IBXFORM'=IBPARFM:1,1:IBSCREEN) D G EDIQ
- . S IBX=+$O(^IBA(364.7,"ALL",IBXDA,"")) ; Check for all ins co and types
- . I IBX,+$O(^IBA(364.7,"ALL",IBXDA,IBX)) D ; Find override for 'ALL'
- .. N Z
- .. 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
- . I 'IBX,+$O(^IBA(364.7,"B",IBXDA,"")) S IBX=$O(^(""))
- . S:IBX IBNMATCH=0
- ;
- I IBXFORM,$O(^IBA(364.6,"APAR",IBXFORM,IBXDA,"")) S IBX=+$O(^("")),IBX=+$O(^IBA(364.7,"B",IBX,0)) I IBX G EDIQ
- S IBX=+$O(^IBA(364.7,"B",IBXDA,""))
- EDIQ I IBSCREEN,$G(IBNMATCH) S IBX=-1
- Q $G(IBX)
- ;
- DT(DATE1,DATE2,FORMAT) ; Return date in DATE1 (and optionally DATE2)
- ; (input in Fileman format) converted to X12 format
- ; FORMAT (required)
- ; DATE1,DATE2 in FILEMAN date format
- N DATE S DATE=""
- I DATE1=0 S DATE1=""
- I $E(FORMAT)="D" D G DTQ
- .S DATE=$E(DATE1,2,7) Q:$P(FORMAT,"D",2)=6 ;YYMMDD
- .S:DATE1 DATE=($E(DATE1)+17)_DATE ;CCYYMMDD
- I $E(FORMAT)="R" D
- .S:DATE1 DATE=$E(DATE1,2,7)_"-"_$E($S($G(DATE2):DATE2,1:DATE1),2,7) ;YYMMDD-YYMMDD
- .Q:FORMAT["6"
- .S DATE=($E(DATE1)+17)_DATE,$P(DATE,"-",2)=($E($S($G(DATE2):DATE2,1:DATE1))+17)_$P(DATE,"-",2) ;CCYYMMDD-CCYYMMDD
- DTQ Q DATE
- ;
- NAME(IBNM1,COMB) ; Parse person's nm into 5 pieces LAST^FIRST^MIDDLE^CRED^SUFFIX
- ; IBNM1 = NAME in LAST,FIRST MIDDLE^vp file ien (200 or 355.93)^bill ien^prv type
- ; OR FIRST MIDDLE LAST^vp file ien (200 or 355.93)^bill ien^prv type
- ; COMB = if set to 1, then combine the first and middle name
- ; if set to 2, combine the last and middle names
- N PC,IBIEN,IBCRED,IBNM,IBNMC,IBPIEN
- S IBIEN=$P(IBNM1,U,2),IBNMC=$P(IBNM1,U)
- S IBPIEN=+$O(^DGCR(399,+$P(IBNM1,U,3),"PRV","B",+$P(IBNM1,U,4),0))
- S IBCRED=$$CRED^IBCEU(IBIEN,+$P(IBNM1,U,3),IBPIEN) ;Degree
- I IBNMC="DEPT VETERANS AFFAIRS" S IBNMC="VETERANS AFFAIRS,DEPT"
- I IBNMC["," D G NAMEQ
- . S IBNMC=$TR(IBNMC,".") D NAMECOMP^XLFNAME(.IBNMC)
- . S IBNM=$G(IBNMC("FAMILY"))_U_$G(IBNMC("GIVEN"))_U_$G(IBNMC("MIDDLE"))_U_IBCRED_U_$G(IBNMC("SUFFIX"))
- D STDNAME^XLFNAME(.IBNMC,"C")
- S IBNM=$G(IBNMC("FAMILY"))_U_$G(IBNMC("GIVEN"))_U_$G(IBNMC("MIDDLE"))_U_IBCRED_U_$G(IBNMC("SUFFIX"))
- 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
- . S IBNM=$P(IBNM1,U)_U_U_U_IBCRED_U
- 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)
- 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)
- ;
- NAMEQ Q IBNM
- ;
- DOLLAR(AMT) ; Format amount in AMT so it is numeric including cents, without
- ; the decimal and commas.
- N DOLR,CENT
- I AMT'="" S AMT=$TR(AMT,","),DOLR=$P(AMT,"."),CENT=$E($P(AMT,".",2)_"00",1,2),AMT=DOLR_CENT
- Q AMT
- ;
- STATE(CODE) ;Return state code from state pointer
- Q $P($G(^DIC(5,+CODE,0)),U,2)
- ;
- SEX(CODE) ;Return the X12 code for sex
- ; CODE = DHCP code for sex
- Q $S(CODE="":"U","MF"[$E(CODE):$E(CODE),1:"U")
- ;
- EMPLST(CODE) ;Return the X12 code for employment status
- ; CODE = DHCP code for employment status
- N X12
- S X12=""
- S:CODE'="" X12=$P($P("1;FT^2;PT^3;NE^4;SE^5;RT^6;AU^9;UK",CODE_";",2),U)
- S:X12="" X12="UK"
- Q X12
- ;
- MARITAL(CODE) ;Return the X12 code for marital status
- ; CODE = ien of code for marital status
- N X12
- S X12=$P($G(^DIC(11,+CODE,0)),U,3)
- I X12'="" S X12=$P($P("D;D^M;M^N;I^S;X^W;W^U;K",X12_";",2),U)
- Q X12
- ;
- TOS(CODE) ;Return the X12 code for type of service
- ; CODE = DHCP code for type of service
- N X12
- 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
- Q X12
- ;
- FIXLEN(DATA,LEN) ; Create a fixed length field from data DATA length LEN
- Q $E(DATA_$J("",LEN),1,LEN)
- ;
- RCDT(IBXSAVE,IBXDATA,IBDT) ; Format date for multiple revenue code transmission)
- ;IBXSAVE = array containing the extracted service line data for the UB format bill
- ;IBXDATA = array returned with service line dates formatted in YYYYMMDD format
- ;IBDT = the default date for the revenue codes on the bill
- ; *644 - replace 1st date with multiple dates
- N Q,W
- S Q=0 F S Q=$O(IBXSAVE("INPT",Q)) Q:'Q S W=$$DT($P(IBXSAVE("INPT",Q),U,10),,"D8"),IBXDATA(Q)=$S(W:W,1:IBDT)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEFG1 6103 printed Jan 18, 2025@03:11:41 Page 2
- IBCEFG1 ;ALB/TMP - OUTPUT FORMATTER DATA DEFINITION UTILITIES ;18-JAN-96
- +1 ;;2.0;INTEGRATED BILLING;**52,51,137,181,197,232,288,349,371,377,644**;21-MAR-94;Build 4
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- EDIBILL(IBXFORM,IBXDA,IBINS,IBTYP) ; Find element associated with form fld
- +1 ; IBXFORM = (REQUIRED) actual form being extracted (in file 353)
- +2 ; IBXDA = (REQUIRED) form definition file (364.6) entry to use to find
- +3 ; extract data element definition entry (in file 364.7)
- +4 ; IBINS = (REQUIRED) insurance co. ien for the current insurance on bill
- +5 ; IBTYP = (REQUIRED) bill type (I/O)
- +6 ;
- +7 ; Returns ien of the entry in file 364.7 if a match on override criteria
- +8 ; was found. Returns -1 if a screen form and the criteria fails for a
- +9 ; field without an override
- +10 ;
- +11 NEW IBX,IBPARFM,IBSCREEN,IBNMATCH,EDIQ,IB1
- +12 IF $GET(IBXDA)=""!($GET(IBXFORM)="")
- GOTO EDIQ
- +13 SET EDIQ=0
- +14 SET IBPARFM=$PIECE($GET(^IBE(353,IBXFORM,2)),U,5)
- if 'IBPARFM
- SET IBPARFM=IBXFORM
- +15 SET IBSCREEN=($PIECE($GET(^IBE(353,+IBXFORM,2)),U,2)="S")
- +16 ; Not a local field that is not a parent
- SET IB1=(IBPARFM=IBXFORM)
- +17 ;
- +18 IF $GET(IBINS)'=""
- IF $GET(IBTYP)'=""
- if $ORDER(^IBA(364.7,"AINTYP",IBXDA,""))'=""
- Begin DoDot:1
- +19 IF '$DATA(^IBA(364.7,"AINTYP",IBXDA,IBINS,IBTYP))
- SET IBNMATCH=1
- QUIT
- +20 ;by ins co and type of bill
- SET IBX=+$ORDER(^IBA(364.7,"AINTYP",IBXDA,IBINS,IBTYP,""))
- SET EDIQ=1
- if IBX
- SET IBNMATCH=0
- End DoDot:1
- if EDIQ
- GOTO EDIQ
- +21 ;
- +22 IF $GET(IBINS)'=""
- if $ORDER(^IBA(364.7,"AINS",IBXDA,""))'=""
- Begin DoDot:1
- +23 IF '$DATA(^IBA(364.7,"AINS",IBXDA,IBINS))
- SET IBNMATCH=1
- QUIT
- +24 ;ins co only
- SET IBX=+$ORDER(^IBA(364.7,"AINS",IBXDA,IBINS,""))
- SET EDIQ=1
- if IBX
- SET IBNMATCH=0
- End DoDot:1
- if EDIQ
- GOTO EDIQ
- +25 ;
- +26 IF $GET(IBTYP)'=""
- if $ORDER(^IBA(364.7,"ATYPE",IBXDA,""))'=""
- Begin DoDot:1
- +27 IF '$DATA(^IBA(364.7,"ATYPE",IBXDA,IBTYP))
- SET IBNMATCH=1
- QUIT
- +28 ;type of bill only
- SET IBX=+$ORDER(^IBA(364.7,"ATYPE",IBXDA,IBTYP,""))
- SET EDIQ=1
- if IBX
- SET IBNMATCH=0
- End DoDot:1
- if EDIQ
- GOTO EDIQ
- +29 ;
- +30 IF IBXFORM
- IF $SELECT(IBXFORM'=IBPARFM:1,1:IBSCREEN)
- Begin DoDot:1
- +31 ; Check for all ins co and types
- SET IBX=+$ORDER(^IBA(364.7,"ALL",IBXDA,""))
- +32 ; Find override for 'ALL'
- IF IBX
- IF +$ORDER(^IBA(364.7,"ALL",IBXDA,IBX))
- Begin DoDot:2
- +33 NEW Z
- +34 SET Z=0
- FOR
- SET Z=$ORDER(^IBA(364.7,"ALL",IBXDA,Z))
- if 'Z
- QUIT
- IF $PIECE($GET(^IBA(364.7,Z,0)),U)'=IBXDA
- SET IBX=Z
- QUIT
- End DoDot:2
- +35 IF 'IBX
- IF +$ORDER(^IBA(364.7,"B",IBXDA,""))
- SET IBX=$ORDER(^(""))
- +36 if IBX
- SET IBNMATCH=0
- End DoDot:1
- GOTO EDIQ
- +37 ;
- +38 IF IBXFORM
- IF $ORDER(^IBA(364.6,"APAR",IBXFORM,IBXDA,""))
- SET IBX=+$ORDER(^(""))
- SET IBX=+$ORDER(^IBA(364.7,"B",IBX,0))
- IF IBX
- GOTO EDIQ
- +39 SET IBX=+$ORDER(^IBA(364.7,"B",IBXDA,""))
- EDIQ IF IBSCREEN
- IF $GET(IBNMATCH)
- SET IBX=-1
- +1 QUIT $GET(IBX)
- +2 ;
- DT(DATE1,DATE2,FORMAT) ; Return date in DATE1 (and optionally DATE2)
- +1 ; (input in Fileman format) converted to X12 format
- +2 ; FORMAT (required)
- +3 ; DATE1,DATE2 in FILEMAN date format
- +4 NEW DATE
- SET DATE=""
- +5 IF DATE1=0
- SET DATE1=""
- +6 IF $EXTRACT(FORMAT)="D"
- Begin DoDot:1
- +7 ;YYMMDD
- SET DATE=$EXTRACT(DATE1,2,7)
- if $PIECE(FORMAT,"D",2)=6
- QUIT
- +8 ;CCYYMMDD
- if DATE1
- SET DATE=($EXTRACT(DATE1)+17)_DATE
- End DoDot:1
- GOTO DTQ
- +9 IF $EXTRACT(FORMAT)="R"
- Begin DoDot:1
- +10 ;YYMMDD-YYMMDD
- if DATE1
- SET DATE=$EXTRACT(DATE1,2,7)_"-"_$EXTRACT($SELECT($GET(DATE2):DATE2,1:DATE1),2,7)
- +11 if FORMAT["6"
- QUIT
- +12 ;CCYYMMDD-CCYYMMDD
- SET DATE=($EXTRACT(DATE1)+17)_DATE
- SET $PIECE(DATE,"-",2)=($EXTRACT($SELECT($GET(DATE2):DATE2,1:DATE1))+17)_$PIECE(DATE,"-",2)
- End DoDot:1
- DTQ QUIT DATE
- +1 ;
- NAME(IBNM1,COMB) ; Parse person's nm into 5 pieces LAST^FIRST^MIDDLE^CRED^SUFFIX
- +1 ; IBNM1 = NAME in LAST,FIRST MIDDLE^vp file ien (200 or 355.93)^bill ien^prv type
- +2 ; OR FIRST MIDDLE LAST^vp file ien (200 or 355.93)^bill ien^prv type
- +3 ; COMB = if set to 1, then combine the first and middle name
- +4 ; if set to 2, combine the last and middle names
- +5 NEW PC,IBIEN,IBCRED,IBNM,IBNMC,IBPIEN
- +6 SET IBIEN=$PIECE(IBNM1,U,2)
- SET IBNMC=$PIECE(IBNM1,U)
- +7 SET IBPIEN=+$ORDER(^DGCR(399,+$PIECE(IBNM1,U,3),"PRV","B",+$PIECE(IBNM1,U,4),0))
- +8 ;Degree
- SET IBCRED=$$CRED^IBCEU(IBIEN,+$PIECE(IBNM1,U,3),IBPIEN)
- +9 IF IBNMC="DEPT VETERANS AFFAIRS"
- SET IBNMC="VETERANS AFFAIRS,DEPT"
- +10 IF IBNMC[","
- Begin DoDot:1
- +11 SET IBNMC=$TRANSLATE(IBNMC,".")
- DO NAMECOMP^XLFNAME(.IBNMC)
- +12 SET IBNM=$GET(IBNMC("FAMILY"))_U_$GET(IBNMC("GIVEN"))_U_$GET(IBNMC("MIDDLE"))_U_IBCRED_U_$GET(IBNMC("SUFFIX"))
- End DoDot:1
- GOTO NAMEQ
- +13 DO STDNAME^XLFNAME(.IBNMC,"C")
- +14 SET IBNM=$GET(IBNMC("FAMILY"))_U_$GET(IBNMC("GIVEN"))_U_$GET(IBNMC("MIDDLE"))_U_IBCRED_U_$GET(IBNMC("SUFFIX"))
- +15 ; group performing provider
- IF $PIECE(IBNM1,U,2)["355.93"
- IF $PIECE($GET(^IBA(355.93,+$PIECE(IBNM1,U,2),0)),U,2)=1
- Begin DoDot:1
- +16 SET IBNM=$PIECE(IBNM1,U)_U_U_U_IBCRED_U
- End DoDot:1
- GOTO NAMEQ
- +17 IF $GET(COMB)=1
- IF $GET(IBNMC("MIDDLE"))'=""
- SET IBNM=$PIECE(IBNM,U)_U_$PIECE(IBNM,U,2)_" "_$PIECE(IBNM,U,3)_U_IBCRED_U_$PIECE(IBNM,U,5)
- +18 IF $GET(COMB)=2
- IF $GET(IBNMC("MIDDLE"))'=""
- SET IBNM=$PIECE(IBNM,U)_" "_$PIECE(IBNM,U,3)_U_$PIECE(IBNM,U,2)_U_IBCRED_U_$PIECE(IBNM,U,5)
- +19 ;
- NAMEQ QUIT IBNM
- +1 ;
- DOLLAR(AMT) ; Format amount in AMT so it is numeric including cents, without
- +1 ; the decimal and commas.
- +2 NEW DOLR,CENT
- +3 IF AMT'=""
- SET AMT=$TRANSLATE(AMT,",")
- SET DOLR=$PIECE(AMT,".")
- SET CENT=$EXTRACT($PIECE(AMT,".",2)_"00",1,2)
- SET AMT=DOLR_CENT
- +4 QUIT AMT
- +5 ;
- STATE(CODE) ;Return state code from state pointer
- +1 QUIT $PIECE($GET(^DIC(5,+CODE,0)),U,2)
- +2 ;
- SEX(CODE) ;Return the X12 code for sex
- +1 ; CODE = DHCP code for sex
- +2 QUIT $SELECT(CODE="":"U","MF"[$EXTRACT(CODE):$EXTRACT(CODE),1:"U")
- +3 ;
- EMPLST(CODE) ;Return the X12 code for employment status
- +1 ; CODE = DHCP code for employment status
- +2 NEW X12
- +3 SET X12=""
- +4 if CODE'=""
- SET X12=$PIECE($PIECE("1;FT^2;PT^3;NE^4;SE^5;RT^6;AU^9;UK",CODE_";",2),U)
- +5 if X12=""
- SET X12="UK"
- +6 QUIT X12
- +7 ;
- MARITAL(CODE) ;Return the X12 code for marital status
- +1 ; CODE = ien of code for marital status
- +2 NEW X12
- +3 SET X12=$PIECE($GET(^DIC(11,+CODE,0)),U,3)
- +4 IF X12'=""
- SET X12=$PIECE($PIECE("D;D^M;M^N;I^S;X^W;W^U;K",X12_";",2),U)
- +5 QUIT X12
- +6 ;
- TOS(CODE) ;Return the X12 code for type of service
- +1 ; CODE = DHCP code for type of service
- +2 NEW X12
- +3 SET X12=$SELECT(CODE>0&(CODE<10):CODE,1:$PIECE($PIECE("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))
- if X12=""
- SET X12=CODE
- +4 QUIT X12
- +5 ;
- FIXLEN(DATA,LEN) ; Create a fixed length field from data DATA length LEN
- +1 QUIT $EXTRACT(DATA_$JUSTIFY("",LEN),1,LEN)
- +2 ;
- RCDT(IBXSAVE,IBXDATA,IBDT) ; Format date for multiple revenue code transmission)
- +1 ;IBXSAVE = array containing the extracted service line data for the UB format bill
- +2 ;IBXDATA = array returned with service line dates formatted in YYYYMMDD format
- +3 ;IBDT = the default date for the revenue codes on the bill
- +4 ; *644 - replace 1st date with multiple dates
- +5 NEW Q,W
- +6 SET Q=0
- FOR
- SET Q=$ORDER(IBXSAVE("INPT",Q))
- if 'Q
- QUIT
- SET W=$$DT($PIECE(IBXSAVE("INPT",Q),U,10),,"D8")
- SET IBXDATA(Q)=$SELECT(W:W,1:IBDT)
- +7 QUIT