IBCF2 ;ALB/ARH - HCFA 1500 19-90 DATA (gather demographics) ;12-JUN-93
;;2.0;INTEGRATED BILLING;**17,52,88,122,51,137,488**;21-MAR-94;Build 184
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
DEV ; IBIFN required
N IBF
S IBFT=$$FTN^IBCU3(2),IBF=$P($G(^IBE(353,+IB,2)),U,8)
S:IBF="" IBF=2 ;Forces the use of the output formatter to print bills
D ENFMT^IBCF(IBIFN,2,IBF)
K IBFT
Q
; Obsolete calls to print bill routines follows
S %ZIS="Q",%ZIS("A")="Output Device: "
S %ZIS("B")=$P($G(^IBE(353,+$P($G(^DGCR(399,IBIFN,0)),"^",19),0)),"^",2)
D ^%ZIS G:POP Q
I $D(IO("Q")) S ZTRTN="EN^IBCF2",ZTDESC="PRINT HCFA1500",ZTSAVE("IB*")="" D ^%ZTLOAD K IO("Q") D HOME^%ZIS G Q
U IO D EN
Q I '$D(ZTQUEUED) D ^%ZISC
Q
;
EN ;begin gathering data for printing of HCFA 1500
;IBIFN must be defined
K IBFLD,IBZ
S IB(0)=$G(^DGCR(399,IBIFN,0)) Q:IB(0)=""
S DFN=+$P(IB(0),U,2) Q:'$D(^DPT(DFN,0)) D ARRAY
S IBJ=1 S:'$D(IBPNT) IBPNT=0 S IBXIEN=IBIFN D F^IBCEF("N-PRINT BILL SUBMIT STATUS","IBZ") S IBFLD(0,1)=IBZ,IBJ=IBJ+1
MAIL F IBI="M","M1" S IB(IBI)=$G(^DGCR(399,IBIFN,IBI))
S IBFLD(0,IBJ)=$P(IB("M"),U,4),IBJ=IBJ+1
F IBI=$P(IB("M"),U,5),$P(IB("M"),U,6),$P(IB("M1"),U,1) I IBI'="" S IBFLD(0,IBJ)=IBI S IBJ=IBJ+1
K Y S Y=$P(IB("M"),U,9) D ZIPOUT^VAFADDR
S IBFLD(0,IBJ)=$P(IB("M"),U,7)_", "_$$STATE(+$P(IB("M"),U,8))_" "_Y
K Y
;
PAT D DEM^VADPT
S IBFLD("1A")=$P(VADM(2),U,2) ; ssn
S IBFLD(2)=VADM(1) ; patient name
S IBFLD("3D")=$$DATE(+VADM(3),1) ; date of birth
S IBFLD("3X")=$P(VADM(5),U,1) ; sex (m/f)
S IBFLD("8M")=$S("146"[+VADM(10):"S","25"[+VADM(10):"M",1:"O") ;marital status
K VADM,VA
S X=+$P($G(^DPT(DFN,.311)),U,15),IBFLD("8E")=$S(",1,2,4,6,"[X:"E",1:"") ;employed?
S IBSPE=+$P($G(^DPT(DFN,.25)),U,15),IBSPE=$S(",1,2,4,6,"[IBSPE:"E",1:"") ; spouse employed?
;
PATADD D ADD^VADPT
S IBFLD(5,1)=VAPA(1)_" "_VAPA(2)_" "_VAPA(3) ;patient's street address
S IBFLD(5,2)=VAPA(4),IBFLD(5,3)=$P(VAPA(11),U,2) ;patient's city, zip
S IBFLD("5S")=$$STATE(+VAPA(5)) ; patient's state
S IBFLD("5T")=VAPA(8) ; patients phone number
K VAPA
;
NEXT D ^IBCF21 ; gather remaining data
;
PRINT D ^IBCF2P ; print
;
END ;set print status
I $G(IBXERR)="",'$G(IBXPARM("TEST")),'$$NEEDMRA^IBEFUNC(IBIFN) D
.S (DIC,DIE)=399,DA=IBIFN,DR="[IB STATUS]",IBYY=$S($P($G(^DGCR(399,IBIFN,"S")),U,12)="":"@92",1:"@94") D ^DIE K DIC,DIE,IBYY,DA,DR
.D BSTAT^IBCDC(IBIFN) ; remove from AB list
;
K DFN,IB,IBI,IBJ,IBK,IBX,IBY,IBSPE,IBFLD,IBFL,IBDXI,X,Y,VAERR
Q
;
ARRAY ; Added "10D" for patch 488
F IBI=1:1:6 S IBFLD(0,IBI)=""
F IBI=1:1:21,23:1:26,28:1:33 S IBFLD(IBI)=""
F IBI=10,16,18 F IBJ="A","B" S IBFLD(IBI_IBJ)=""
F IBI="10BS","10C","10D","11AX","11B","11C","11D","1A","3D","3X","5S","5T","8E","8M","9A","9BD","9BX","9C","9D","17A" S IBFLD(IBI)=""
Q
;
DATE(X,Y2K,NULL) ; returns date in form format
; X = date in FM format, Y2K = 1 if 4 digit year required
; If NULL = 1, then the delimiter should be null, not space
; Format is MM DD YY or MMDDYY or MM DD YYYY or MMDDYYYY
N IBDELIM
S Y2K=+$G(Y2K) S:Y2K>1 Y2K=1
S IBDELIM=$S('$G(NULL):" ",1:"")
Q $S(X:$E(X,4,5)_IBDELIM_$E(X,6,7)_IBDELIM_$S($G(Y2K):$E(X,1,3)+(Y2K*1700),1:$E(X,2,3)),1:X)
;
STATE(X) ; returns 2 letter abbreviation for state pointer
Q $P($G(^DIC(5,+X,0)),U,2)
;
ENF ;Output the bill via formatter
N Z
S Z=$$EXTRACT^IBCEFG(2,IBIFN)
Q
;
NAME31(IBIFN,IBZNM) ; Returns the name of the provider
; formatted to print in Box 31 on the HCFA 1500. Max length is 21
; IBZNM = PROVIDER NAME in last,first<space>middle^file 200 ien^cred
N IBXDATA,IBZ,IBNM,IBMID,IBMIDI,IB1,IB2
I '$D(^DGCR(399,IBIFN,"PRV",0)) S IBNM=$E($P($G(IBZNM),U),1,21) G NAMEQ
I $G(IBZNM)="" D ;
. D F^IBCEF("N-ATT/REND PHYSICIAN NAME","IBZNM",,IBIFN)
S IBNM=$$NAME^IBCEFG1($P(IBZNM,U,1,2)) ;returns last^first^middle
S IB1=$P(IBNM,U,2),IB2=$P(IBNM,U),IBMID=$S($P(IBNM,U,3)'="":" "_$P(IBNM,U,3)_" ",1:" "),IBMIDI=$E($P(IBNM,U,3))_" "
;
I $L(IB2)>21 S IBNM=$E(IB2,1,21) G NAMEQ ; Last name truncated
S IBNM=IB1_IBMID_IB2 ; First-name middle-name last-name
; Trim it to 21 characters according to formula
I $L(IBNM)'>21 G NAMEQ ; First-init middle-init last-name
S IBNM=$E(IB1)_IBMIDI_IB2
I $L(IBNM)'>21 G NAMEQ ; Last-name only
S IBNM=IB2
;
NAMEQ Q IBNM
;
DATE31(IBDT,IBIFN) ; Returns date to print in box 31 of HCFA 1500
; Either first print date (IBDT) or today's date if never printed
I $G(IBIFN),'$D(^DGCR(399,IBIFN,"PRV",0)) Q ""
I IBDT="" S IBDT=DT
Q $$FMTE^XLFDT(IBDT,"5D")
;
;
; Start ->BAA *488*
DXIND(IBIFN) ; Returns 0 for ICD10 codes and 9 for ICD9 codes.
; This sets the diagnosis ind to a 9. If the diagnosis is ICD10
; it is set to zero
N IBDXX,IBPOX,IBDXI,ICD,DATA
D SET^IBCSC4D(IBIFN,.IBDXX,.IBPOX)
S IBDXI=""
I $G(IBPOX(1)) D
.S ICD=$P(IBPOX(1),U,1)
.S IBDXI=9
.S DATA=$$ICD9^IBACSV(ICD) I $P(DATA,U,19)=30 S IBDXI=0
Q IBDXI
; End ->BAA *488*
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCF2 5006 printed Oct 16, 2024@18:13:31 Page 2
IBCF2 ;ALB/ARH - HCFA 1500 19-90 DATA (gather demographics) ;12-JUN-93
+1 ;;2.0;INTEGRATED BILLING;**17,52,88,122,51,137,488**;21-MAR-94;Build 184
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
DEV ; IBIFN required
+1 NEW IBF
+2 SET IBFT=$$FTN^IBCU3(2)
SET IBF=$PIECE($GET(^IBE(353,+IB,2)),U,8)
+3 ;Forces the use of the output formatter to print bills
if IBF=""
SET IBF=2
+4 DO ENFMT^IBCF(IBIFN,2,IBF)
+5 KILL IBFT
+6 QUIT
+7 ; Obsolete calls to print bill routines follows
+8 SET %ZIS="Q"
SET %ZIS("A")="Output Device: "
+9 SET %ZIS("B")=$PIECE($GET(^IBE(353,+$PIECE($GET(^DGCR(399,IBIFN,0)),"^",19),0)),"^",2)
+10 DO ^%ZIS
if POP
GOTO Q
+11 IF $DATA(IO("Q"))
SET ZTRTN="EN^IBCF2"
SET ZTDESC="PRINT HCFA1500"
SET ZTSAVE("IB*")=""
DO ^%ZTLOAD
KILL IO("Q")
DO HOME^%ZIS
GOTO Q
+12 USE IO
DO EN
Q IF '$DATA(ZTQUEUED)
DO ^%ZISC
+1 QUIT
+2 ;
EN ;begin gathering data for printing of HCFA 1500
+1 ;IBIFN must be defined
+2 KILL IBFLD,IBZ
+3 SET IB(0)=$GET(^DGCR(399,IBIFN,0))
if IB(0)=""
QUIT
+4 SET DFN=+$PIECE(IB(0),U,2)
if '$DATA(^DPT(DFN,0))
QUIT
DO ARRAY
+5 SET IBJ=1
if '$DATA(IBPNT)
SET IBPNT=0
SET IBXIEN=IBIFN
DO F^IBCEF("N-PRINT BILL SUBMIT STATUS","IBZ")
SET IBFLD(0,1)=IBZ
SET IBJ=IBJ+1
MAIL FOR IBI="M","M1"
SET IB(IBI)=$GET(^DGCR(399,IBIFN,IBI))
+1 SET IBFLD(0,IBJ)=$PIECE(IB("M"),U,4)
SET IBJ=IBJ+1
+2 FOR IBI=$PIECE(IB("M"),U,5),$PIECE(IB("M"),U,6),$PIECE(IB("M1"),U,1)
IF IBI'=""
SET IBFLD(0,IBJ)=IBI
SET IBJ=IBJ+1
+3 KILL Y
SET Y=$PIECE(IB("M"),U,9)
DO ZIPOUT^VAFADDR
+4 SET IBFLD(0,IBJ)=$PIECE(IB("M"),U,7)_", "_$$STATE(+$PIECE(IB("M"),U,8))_" "_Y
+5 KILL Y
+6 ;
PAT DO DEM^VADPT
+1 ; ssn
SET IBFLD("1A")=$PIECE(VADM(2),U,2)
+2 ; patient name
SET IBFLD(2)=VADM(1)
+3 ; date of birth
SET IBFLD("3D")=$$DATE(+VADM(3),1)
+4 ; sex (m/f)
SET IBFLD("3X")=$PIECE(VADM(5),U,1)
+5 ;marital status
SET IBFLD("8M")=$SELECT("146"[+VADM(10):"S","25"[+VADM(10):"M",1:"O")
+6 KILL VADM,VA
+7 ;employed?
SET X=+$PIECE($GET(^DPT(DFN,.311)),U,15)
SET IBFLD("8E")=$SELECT(",1,2,4,6,"[X:"E",1:"")
+8 ; spouse employed?
SET IBSPE=+$PIECE($GET(^DPT(DFN,.25)),U,15)
SET IBSPE=$SELECT(",1,2,4,6,"[IBSPE:"E",1:"")
+9 ;
PATADD DO ADD^VADPT
+1 ;patient's street address
SET IBFLD(5,1)=VAPA(1)_" "_VAPA(2)_" "_VAPA(3)
+2 ;patient's city, zip
SET IBFLD(5,2)=VAPA(4)
SET IBFLD(5,3)=$PIECE(VAPA(11),U,2)
+3 ; patient's state
SET IBFLD("5S")=$$STATE(+VAPA(5))
+4 ; patients phone number
SET IBFLD("5T")=VAPA(8)
+5 KILL VAPA
+6 ;
NEXT ; gather remaining data
DO ^IBCF21
+1 ;
PRINT ; print
DO ^IBCF2P
+1 ;
END ;set print status
+1 IF $GET(IBXERR)=""
IF '$GET(IBXPARM("TEST"))
IF '$$NEEDMRA^IBEFUNC(IBIFN)
Begin DoDot:1
+2 SET (DIC,DIE)=399
SET DA=IBIFN
SET DR="[IB STATUS]"
SET IBYY=$SELECT($PIECE($GET(^DGCR(399,IBIFN,"S")),U,12)="":"@92",1:"@94")
DO ^DIE
KILL DIC,DIE,IBYY,DA,DR
+3 ; remove from AB list
DO BSTAT^IBCDC(IBIFN)
End DoDot:1
+4 ;
+5 KILL DFN,IB,IBI,IBJ,IBK,IBX,IBY,IBSPE,IBFLD,IBFL,IBDXI,X,Y,VAERR
+6 QUIT
+7 ;
ARRAY ; Added "10D" for patch 488
+1 FOR IBI=1:1:6
SET IBFLD(0,IBI)=""
+2 FOR IBI=1:1:21,23:1:26,28:1:33
SET IBFLD(IBI)=""
+3 FOR IBI=10,16,18
FOR IBJ="A","B"
SET IBFLD(IBI_IBJ)=""
+4 FOR IBI="10BS","10C","10D","11AX","11B","11C","11D","1A","3D","3X","5S","5T","8E","8M","9A","9BD","9BX","9C","9D","17A"
SET IBFLD(IBI)=""
+5 QUIT
+6 ;
DATE(X,Y2K,NULL) ; returns date in form format
+1 ; X = date in FM format, Y2K = 1 if 4 digit year required
+2 ; If NULL = 1, then the delimiter should be null, not space
+3 ; Format is MM DD YY or MMDDYY or MM DD YYYY or MMDDYYYY
+4 NEW IBDELIM
+5 SET Y2K=+$GET(Y2K)
if Y2K>1
SET Y2K=1
+6 SET IBDELIM=$SELECT('$GET(NULL):" ",1:"")
+7 QUIT $SELECT(X:$EXTRACT(X,4,5)_IBDELIM_$EXTRACT(X,6,7)_IBDELIM_$SELECT($GET(Y2K):$EXTRACT(X,1,3)+(Y2K*1700),1:$EXTRACT(X,2,3)),1:X)
+8 ;
STATE(X) ; returns 2 letter abbreviation for state pointer
+1 QUIT $PIECE($GET(^DIC(5,+X,0)),U,2)
+2 ;
ENF ;Output the bill via formatter
+1 NEW Z
+2 SET Z=$$EXTRACT^IBCEFG(2,IBIFN)
+3 QUIT
+4 ;
NAME31(IBIFN,IBZNM) ; Returns the name of the provider
+1 ; formatted to print in Box 31 on the HCFA 1500. Max length is 21
+2 ; IBZNM = PROVIDER NAME in last,first<space>middle^file 200 ien^cred
+3 NEW IBXDATA,IBZ,IBNM,IBMID,IBMIDI,IB1,IB2
+4 IF '$DATA(^DGCR(399,IBIFN,"PRV",0))
SET IBNM=$EXTRACT($PIECE($GET(IBZNM),U),1,21)
GOTO NAMEQ
+5 ;
IF $GET(IBZNM)=""
Begin DoDot:1
+6 DO F^IBCEF("N-ATT/REND PHYSICIAN NAME","IBZNM",,IBIFN)
End DoDot:1
+7 ;returns last^first^middle
SET IBNM=$$NAME^IBCEFG1($PIECE(IBZNM,U,1,2))
+8 SET IB1=$PIECE(IBNM,U,2)
SET IB2=$PIECE(IBNM,U)
SET IBMID=$SELECT($PIECE(IBNM,U,3)'="":" "_$PIECE(IBNM,U,3)_" ",1:" ")
SET IBMIDI=$EXTRACT($PIECE(IBNM,U,3))_" "
+9 ;
+10 ; Last name truncated
IF $LENGTH(IB2)>21
SET IBNM=$EXTRACT(IB2,1,21)
GOTO NAMEQ
+11 ; First-name middle-name last-name
SET IBNM=IB1_IBMID_IB2
+12 ; Trim it to 21 characters according to formula
+13 ; First-init middle-init last-name
IF $LENGTH(IBNM)'>21
GOTO NAMEQ
+14 SET IBNM=$EXTRACT(IB1)_IBMIDI_IB2
+15 ; Last-name only
IF $LENGTH(IBNM)'>21
GOTO NAMEQ
+16 SET IBNM=IB2
+17 ;
NAMEQ QUIT IBNM
+1 ;
DATE31(IBDT,IBIFN) ; Returns date to print in box 31 of HCFA 1500
+1 ; Either first print date (IBDT) or today's date if never printed
+2 IF $GET(IBIFN)
IF '$DATA(^DGCR(399,IBIFN,"PRV",0))
QUIT ""
+3 IF IBDT=""
SET IBDT=DT
+4 QUIT $$FMTE^XLFDT(IBDT,"5D")
+5 ;
+6 ;
+7 ; Start ->BAA *488*
DXIND(IBIFN) ; Returns 0 for ICD10 codes and 9 for ICD9 codes.
+1 ; This sets the diagnosis ind to a 9. If the diagnosis is ICD10
+2 ; it is set to zero
+3 NEW IBDXX,IBPOX,IBDXI,ICD,DATA
+4 DO SET^IBCSC4D(IBIFN,.IBDXX,.IBPOX)
+5 SET IBDXI=""
+6 IF $GET(IBPOX(1))
Begin DoDot:1
+7 SET ICD=$PIECE(IBPOX(1),U,1)
+8 SET IBDXI=9
+9 SET DATA=$$ICD9^IBACSV(ICD)
IF $PIECE(DATA,U,19)=30
SET IBDXI=0
End DoDot:1
+10 QUIT IBDXI
+11 ; End ->BAA *488*
