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

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.3 KB
Line 
1IBCF2 ;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 ;
5DEV ; 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
18Q I '$D(ZTQUEUED) D ^%ZISC
19 Q
20 ;
21EN ;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
27MAIL 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 ;
34PAT 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 ;
44PATADD 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 ;
51NEXT D ^IBCF21 ; gather remaining data
52 ;
53PRINT D ^IBCF2P ; print
54 ;
55END ;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 ;
63ARRAY ;
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 ;
70DATE(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 ;
79STATE(X) ; returns 2 letter abbreviation for state pointer
80 Q $P($G(^DIC(5,+X,0)),U,2)
81 ;
82ENF ;Output the bill via formatter
83 N Z
84 S Z=$$EXTRACT^IBCEFG(2,IBIFN)
85 Q
86 ;
87NAME31(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 ;
105NAMEQ Q IBNM
106 ;
107DATE31(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 ;
Note: See TracBrowser for help on using the repository browser.