| 1 | IBCF2 ;ALB/ARH - HCFA 1500 19-90 DATA (gather demographics) ;12-JUN-93
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**17,52,88,122,51,137**;21-MAR-94
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | DEV ; IBIFN required
|
|---|
| 6 | N IBF
|
|---|
| 7 | S IBFT=$$FTN^IBCU3(2),IBF=$P($G(^IBE(353,+IB,2)),U,8)
|
|---|
| 8 | S:IBF="" IBF=2 ;Forces the use of the output formatter to print bills
|
|---|
| 9 | D ENFMT^IBCF(IBIFN,2,IBF)
|
|---|
| 10 | K IBFT
|
|---|
| 11 | Q
|
|---|
| 12 | ; Obsolete calls to print bill routines follows
|
|---|
| 13 | S %ZIS="Q",%ZIS("A")="Output Device: "
|
|---|
| 14 | S %ZIS("B")=$P($G(^IBE(353,+$P($G(^DGCR(399,IBIFN,0)),"^",19),0)),"^",2)
|
|---|
| 15 | D ^%ZIS G:POP Q
|
|---|
| 16 | I $D(IO("Q")) S ZTRTN="EN^IBCF2",ZTDESC="PRINT HCFA1500",ZTSAVE("IB*")="" D ^%ZTLOAD K IO("Q") D HOME^%ZIS G Q
|
|---|
| 17 | U IO D EN
|
|---|
| 18 | Q I '$D(ZTQUEUED) D ^%ZISC
|
|---|
| 19 | Q
|
|---|
| 20 | ;
|
|---|
| 21 | EN ;begin gathering data for printing of HCFA 1500
|
|---|
| 22 | ;IBIFN must be defined
|
|---|
| 23 | K IBFLD,IBZ
|
|---|
| 24 | S IB(0)=$G(^DGCR(399,IBIFN,0)) Q:IB(0)=""
|
|---|
| 25 | S DFN=+$P(IB(0),U,2) Q:'$D(^DPT(DFN,0)) D ARRAY
|
|---|
| 26 | 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
|
|---|
| 27 | MAIL F IBI="M","M1" S IB(IBI)=$G(^DGCR(399,IBIFN,IBI))
|
|---|
| 28 | S IBFLD(0,IBJ)=$P(IB("M"),U,4),IBJ=IBJ+1
|
|---|
| 29 | 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
|
|---|
| 30 | K Y S Y=$P(IB("M"),U,9) D ZIPOUT^VAFADDR
|
|---|
| 31 | S IBFLD(0,IBJ)=$P(IB("M"),U,7)_", "_$$STATE(+$P(IB("M"),U,8))_" "_Y
|
|---|
| 32 | K Y
|
|---|
| 33 | ;
|
|---|
| 34 | PAT D DEM^VADPT
|
|---|
| 35 | S IBFLD("1A")=$P(VADM(2),U,2) ; ssn
|
|---|
| 36 | S IBFLD(2)=VADM(1) ; patient name
|
|---|
| 37 | S IBFLD("3D")=$$DATE(+VADM(3),1) ; date of birth
|
|---|
| 38 | S IBFLD("3X")=$P(VADM(5),U,1) ; sex (m/f)
|
|---|
| 39 | S IBFLD("8M")=$S("146"[+VADM(10):"S","25"[+VADM(10):"M",1:"O") ;marital status
|
|---|
| 40 | K VADM,VA
|
|---|
| 41 | S X=+$P($G(^DPT(DFN,.311)),U,15),IBFLD("8E")=$S(",1,2,4,6,"[X:"E",1:"") ;employed?
|
|---|
| 42 | S IBSPE=+$P($G(^DPT(DFN,.25)),U,15),IBSPE=$S(",1,2,4,6,"[IBSPE:"E",1:"") ; spouse employed?
|
|---|
| 43 | ;
|
|---|
| 44 | PATADD D ADD^VADPT
|
|---|
| 45 | S IBFLD(5,1)=VAPA(1)_" "_VAPA(2)_" "_VAPA(3) ;patient's street address
|
|---|
| 46 | S IBFLD(5,2)=VAPA(4),IBFLD(5,3)=$P(VAPA(11),U,2) ;patient's city, zip
|
|---|
| 47 | S IBFLD("5S")=$$STATE(+VAPA(5)) ; patient's state
|
|---|
| 48 | S IBFLD("5T")=VAPA(8) ; patients phone number
|
|---|
| 49 | K VAPA
|
|---|
| 50 | ;
|
|---|
| 51 | NEXT D ^IBCF21 ; gather remaining data
|
|---|
| 52 | ;
|
|---|
| 53 | PRINT D ^IBCF2P ; print
|
|---|
| 54 | ;
|
|---|
| 55 | END ;set print status
|
|---|
| 56 | I $G(IBXERR)="",'$G(IBXPARM("TEST")),'$$NEEDMRA^IBEFUNC(IBIFN) D
|
|---|
| 57 | .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
|
|---|
| 58 | .D BSTAT^IBCDC(IBIFN) ; remove from AB list
|
|---|
| 59 | ;
|
|---|
| 60 | K DFN,IB,IBI,IBJ,IBK,IBX,IBY,IBSPE,IBFLD,IBFL,IBDXI,X,Y,VAERR
|
|---|
| 61 | Q
|
|---|
| 62 | ;
|
|---|
| 63 | ARRAY ;
|
|---|
| 64 | F IBI=1:1:6 S IBFLD(0,IBI)=""
|
|---|
| 65 | F IBI=1:1:21,23:1:26,28:1:33 S IBFLD(IBI)=""
|
|---|
| 66 | F IBI=10,16,18 F IBJ="A","B" S IBFLD(IBI_IBJ)=""
|
|---|
| 67 | F IBI="10BS","10C","11AX","11B","11C","11D","1A","3D","3X","5S","5T","8E","8M","9A","9BD","9BX","9C","9D","17A" S IBFLD(IBI)=""
|
|---|
| 68 | Q
|
|---|
| 69 | ;
|
|---|
| 70 | DATE(X,Y2K,NULL) ; returns date in form format
|
|---|
| 71 | ; X = date in FM format, Y2K = 1 if 4 digit year required
|
|---|
| 72 | ; If NULL = 1, then the delimiter should be null, not space
|
|---|
| 73 | ; Format is MM DD YY or MMDDYY or MM DD YYYY or MMDDYYYY
|
|---|
| 74 | N IBDELIM
|
|---|
| 75 | S Y2K=+$G(Y2K) S:Y2K>1 Y2K=1
|
|---|
| 76 | S IBDELIM=$S('$G(NULL):" ",1:"")
|
|---|
| 77 | 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)
|
|---|
| 78 | ;
|
|---|
| 79 | STATE(X) ; returns 2 letter abbreviation for state pointer
|
|---|
| 80 | Q $P($G(^DIC(5,+X,0)),U,2)
|
|---|
| 81 | ;
|
|---|
| 82 | ENF ;Output the bill via formatter
|
|---|
| 83 | N Z
|
|---|
| 84 | S Z=$$EXTRACT^IBCEFG(2,IBIFN)
|
|---|
| 85 | Q
|
|---|
| 86 | ;
|
|---|
| 87 | NAME31(IBIFN,IBZNM) ; Returns the name of the provider
|
|---|
| 88 | ; formatted to print in Box 31 on the HCFA 1500. Max length is 21
|
|---|
| 89 | ; IBZNM = PROVIDER NAME in last,first<space>middle^file 200 ien^cred
|
|---|
| 90 | N IBXDATA,IBZ,IBNM,IBMID,IBMIDI,IB1,IB2
|
|---|
| 91 | I '$D(^DGCR(399,IBIFN,"PRV",0)) S IBNM=$E($P($G(IBZNM),U),1,21) G NAMEQ
|
|---|
| 92 | I $G(IBZNM)="" D ;
|
|---|
| 93 | . D F^IBCEF("N-ATT/REND PHYSICIAN NAME","IBZNM",,IBIFN)
|
|---|
| 94 | S IBNM=$$NAME^IBCEFG1($P(IBZNM,U,1,2)) ;returns last^first^middle
|
|---|
| 95 | 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))_" "
|
|---|
| 96 | ;
|
|---|
| 97 | I $L(IB2)>21 S IBNM=$E(IB2,1,21) G NAMEQ ; Last name truncated
|
|---|
| 98 | S IBNM=IB1_IBMID_IB2 ; First-name middle-name last-name
|
|---|
| 99 | ; Trim it to 21 characters according to formula
|
|---|
| 100 | I $L(IBNM)'>21 G NAMEQ ; First-init middle-init last-name
|
|---|
| 101 | S IBNM=$E(IB1)_IBMIDI_IB2
|
|---|
| 102 | I $L(IBNM)'>21 G NAMEQ ; Last-name only
|
|---|
| 103 | S IBNM=IB2
|
|---|
| 104 | ;
|
|---|
| 105 | NAMEQ Q IBNM
|
|---|
| 106 | ;
|
|---|
| 107 | DATE31(IBDT,IBIFN) ; Returns date to print in box 31 of HCFA 1500
|
|---|
| 108 | ; Either first print date (IBDT) or today's date if never printed
|
|---|
| 109 | I $G(IBIFN),'$D(^DGCR(399,IBIFN,"PRV",0)) Q ""
|
|---|
| 110 | I IBDT="" S IBDT=DT
|
|---|
| 111 | Q $$FMTE^XLFDT(IBDT,"5D")
|
|---|
| 112 | ;
|
|---|
