Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCF2

IBCF2.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. DEV ; IBIFN required
  1. N IBF
  1. S IBFT=$$FTN^IBCU3(2),IBF=$P($G(^IBE(353,+IB,2)),U,8)
  1. S:IBF="" IBF=2 ;Forces the use of the output formatter to print bills
  1. D ENFMT^IBCF(IBIFN,2,IBF)
  1. K IBFT
  1. Q
  1. ; Obsolete calls to print bill routines follows
  1. S %ZIS="Q",%ZIS("A")="Output Device: "
  1. S %ZIS("B")=$P($G(^IBE(353,+$P($G(^DGCR(399,IBIFN,0)),"^",19),0)),"^",2)
  1. D ^%ZIS G:POP Q
  1. I $D(IO("Q")) S ZTRTN="EN^IBCF2",ZTDESC="PRINT HCFA1500",ZTSAVE("IB*")="" D ^%ZTLOAD K IO("Q") D HOME^%ZIS G Q
  1. U IO D EN
  1. Q I '$D(ZTQUEUED) D ^%ZISC
  1. Q
  1. ;
  1. EN ;begin gathering data for printing of HCFA 1500
  1. ;IBIFN must be defined
  1. K IBFLD,IBZ
  1. S IB(0)=$G(^DGCR(399,IBIFN,0)) Q:IB(0)=""
  1. S DFN=+$P(IB(0),U,2) Q:'$D(^DPT(DFN,0)) D ARRAY
  1. 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
  1. MAIL F IBI="M","M1" S IB(IBI)=$G(^DGCR(399,IBIFN,IBI))
  1. S IBFLD(0,IBJ)=$P(IB("M"),U,4),IBJ=IBJ+1
  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
  1. K Y S Y=$P(IB("M"),U,9) D ZIPOUT^VAFADDR
  1. S IBFLD(0,IBJ)=$P(IB("M"),U,7)_", "_$$STATE(+$P(IB("M"),U,8))_" "_Y
  1. K Y
  1. ;
  1. PAT D DEM^VADPT
  1. S IBFLD("1A")=$P(VADM(2),U,2) ; ssn
  1. S IBFLD(2)=VADM(1) ; patient name
  1. S IBFLD("3D")=$$DATE(+VADM(3),1) ; date of birth
  1. S IBFLD("3X")=$P(VADM(5),U,1) ; sex (m/f)
  1. S IBFLD("8M")=$S("146"[+VADM(10):"S","25"[+VADM(10):"M",1:"O") ;marital status
  1. K VADM,VA
  1. S X=+$P($G(^DPT(DFN,.311)),U,15),IBFLD("8E")=$S(",1,2,4,6,"[X:"E",1:"") ;employed?
  1. S IBSPE=+$P($G(^DPT(DFN,.25)),U,15),IBSPE=$S(",1,2,4,6,"[IBSPE:"E",1:"") ; spouse employed?
  1. ;
  1. PATADD D ADD^VADPT
  1. S IBFLD(5,1)=VAPA(1)_" "_VAPA(2)_" "_VAPA(3) ;patient's street address
  1. S IBFLD(5,2)=VAPA(4),IBFLD(5,3)=$P(VAPA(11),U,2) ;patient's city, zip
  1. S IBFLD("5S")=$$STATE(+VAPA(5)) ; patient's state
  1. S IBFLD("5T")=VAPA(8) ; patients phone number
  1. K VAPA
  1. ;
  1. NEXT D ^IBCF21 ; gather remaining data
  1. ;
  1. PRINT D ^IBCF2P ; print
  1. ;
  1. END ;set print status
  1. I $G(IBXERR)="",'$G(IBXPARM("TEST")),'$$NEEDMRA^IBEFUNC(IBIFN) D
  1. .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
  1. .D BSTAT^IBCDC(IBIFN) ; remove from AB list
  1. ;
  1. K DFN,IB,IBI,IBJ,IBK,IBX,IBY,IBSPE,IBFLD,IBFL,IBDXI,X,Y,VAERR
  1. Q
  1. ;
  1. ARRAY ; Added "10D" for patch 488
  1. F IBI=1:1:6 S IBFLD(0,IBI)=""
  1. F IBI=1:1:21,23:1:26,28:1:33 S IBFLD(IBI)=""
  1. F IBI=10,16,18 F IBJ="A","B" S IBFLD(IBI_IBJ)=""
  1. 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)=""
  1. Q
  1. ;
  1. DATE(X,Y2K,NULL) ; returns date in form format
  1. ; X = date in FM format, Y2K = 1 if 4 digit year required
  1. ; If NULL = 1, then the delimiter should be null, not space
  1. ; Format is MM DD YY or MMDDYY or MM DD YYYY or MMDDYYYY
  1. N IBDELIM
  1. S Y2K=+$G(Y2K) S:Y2K>1 Y2K=1
  1. S IBDELIM=$S('$G(NULL):" ",1:"")
  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)
  1. ;
  1. STATE(X) ; returns 2 letter abbreviation for state pointer
  1. Q $P($G(^DIC(5,+X,0)),U,2)
  1. ;
  1. ENF ;Output the bill via formatter
  1. N Z
  1. S Z=$$EXTRACT^IBCEFG(2,IBIFN)
  1. Q
  1. ;
  1. NAME31(IBIFN,IBZNM) ; Returns the name of the provider
  1. ; formatted to print in Box 31 on the HCFA 1500. Max length is 21
  1. ; IBZNM = PROVIDER NAME in last,first<space>middle^file 200 ien^cred
  1. N IBXDATA,IBZ,IBNM,IBMID,IBMIDI,IB1,IB2
  1. I '$D(^DGCR(399,IBIFN,"PRV",0)) S IBNM=$E($P($G(IBZNM),U),1,21) G NAMEQ
  1. I $G(IBZNM)="" D ;
  1. . D F^IBCEF("N-ATT/REND PHYSICIAN NAME","IBZNM",,IBIFN)
  1. S IBNM=$$NAME^IBCEFG1($P(IBZNM,U,1,2)) ;returns last^first^middle
  1. 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))_" "
  1. ;
  1. I $L(IB2)>21 S IBNM=$E(IB2,1,21) G NAMEQ ; Last name truncated
  1. S IBNM=IB1_IBMID_IB2 ; First-name middle-name last-name
  1. ; Trim it to 21 characters according to formula
  1. I $L(IBNM)'>21 G NAMEQ ; First-init middle-init last-name
  1. S IBNM=$E(IB1)_IBMIDI_IB2
  1. I $L(IBNM)'>21 G NAMEQ ; Last-name only
  1. S IBNM=IB2
  1. ;
  1. NAMEQ Q IBNM
  1. ;
  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
  1. I $G(IBIFN),'$D(^DGCR(399,IBIFN,"PRV",0)) Q ""
  1. I IBDT="" S IBDT=DT
  1. Q $$FMTE^XLFDT(IBDT,"5D")
  1. ;
  1. ;
  1. ; Start ->BAA *488*
  1. 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
  1. ; it is set to zero
  1. N IBDXX,IBPOX,IBDXI,ICD,DATA
  1. D SET^IBCSC4D(IBIFN,.IBDXX,.IBPOX)
  1. S IBDXI=""
  1. I $G(IBPOX(1)) D
  1. .S ICD=$P(IBPOX(1),U,1)
  1. .S IBDXI=9
  1. .S DATA=$$ICD9^IBACSV(ICD) I $P(DATA,U,19)=30 S IBDXI=0
  1. Q IBDXI
  1. ; End ->BAA *488*