- 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 Jan 18, 2025@03:14:03 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*