source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF2.m@ 1800

IBCF2 ;ALB/ARH - HCFA 1500 19-90 DATA (gather demographics) ;12-JUN-93

 ;;2.0;INTEGRATED BILLING;**17,52,88,122,51,137**;21-MAR-94

 ;;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 ;

 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","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")

 ;