source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF3.m@ 1806

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

initial load of FOIAVistA 6/30/08 version

File size: 4.6 KB
Line 
1IBCF3 ;ALB/BGA -UB92 HCFA-1450 (gather demographics) ;19-AUG-93
2 ;;2.0;INTEGRATED BILLING;**8,52,80,109,51**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5DEV ;
6 N IBF
7 S IBFT=$$FTN^IBCU3(3),IBF=$P($G(^IBE(353,+IB,2)),U,8)
8 S:IBF="" IBF=3 ;Forces the use of the output formatter to print bills
9 D ENFMT^IBCF(IBIFN,3,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")=$$BILLDEV^IBCU3(IBIFN)
15 D ^%ZIS G:POP Q
16 I $D(IO("Q")) S ZTRTN="EN^IBCF3",ZTDESC="PRINT UB-92 BILL",ZTSAVE("IB*")="",ZTSAVE("DG*")="",ZTSAVE("DFN")="" D ^%ZTLOAD K IO("Q") D HOME^%ZIS G Q
17 ;
18 U IO D EN
19Q Q:$D(ZTQUEUED) D ^%ZISC
20 Q
21 ;
22EN ;This routine gathers demographics for printing of ub92 form.
23 ;Fields 1 to 21 are addressed in this routine.
24 ;IBIFN must be defined...
25 ;
26 I '$D(IBPNT) S IBPNT=0
27 ;find out if a manual signature is required
28 S IBCBILL=$G(^DGCR(399,+IBIFN,0)) I IBCBILL="" G EXIT
29 S IBCU2=$G(^DGCR(399,+IBIFN,"U2")),IBCUF3=$G(^DGCR(399,+IBIFN,"UF3")),IBCUF31=$G(^DGCR(399,+IBIFN,"UF31"))
30 S IBCINSN=$P($G(^DGCR(399,+IBIFN,"MP")),U,1),IBCINSN=$G(^DIC(36,+IBCINSN,0))
31 S IBFL(0,"SR")=$S(+$P(IBCINSN,U,3):"##SR",1:"") ; signature required on bill
32 S IBFL(0,"ZBILL")=$S(IBPNT=1:"",IBPNT=0:"*** COPY OF ORIGINAL BILL ***",IBPNT=2:"*** SECOND NOTICE ***",IBPNT=3:"*** THIRD NOTICE ***",1:"")
33 ;provider name and address ^ibe(350.9,1,2)
34 S IBX=$G(^IBE(350.9,1,2)) ;site parameter file
35 S IBFL(1,"PROVL1")=$P(IBX,U,1),IBFL(1,"PROVL2")=$P(IBX,U,2)
36 S IBFL(1,"PROVL3")=$P(IBX,U,3)_" "_$P($G(^DIC(5,+$P(IBX,U,4),0)),U,2)_" "_$P(IBX,U,5)
37 S IBFL(1,"PROVL4")=$P(IBX,U,6) ; agent cashier phone
38 S IBX=$P(IBCUF3,U,1) D SPLIT^IBCF3(2,2,30,IBX) ; set IBFL(2)
39 S IBFL(3)=$$BN1^PRCAFN(IBIFN)
40 ;
41 S IBFL(4)=$P(IBCBILL,U,24)_$P($G(^DGCR(399.1,+$P(IBCBILL,U,25),0)),U,2)_$P(IBCBILL,U,26)
42 ;site paramater
43 S IBSIGN=$G(^IBE(350.9,1,1)) S IBFL(5)=$P(IBSIGN,U,5)
44 ;statement covers period
45 S IBSTATE=$G(^DGCR(399,+IBIFN,"U"))
46 S IBFL(6,"FROM")=$$DATE(+$P(IBSTATE,U,1)),IBFL(6,"TO")=$$DATE(+$P(IBSTATE,U,2))
47 S IBFL(7)=$P(IBCU2,U,2),IBFL(8)=$P(IBCU2,U,3)
48 S IBX=$P(IBCUF3,U,2) D SPLIT^IBCF3(11,2,13,IBX) ; set IBFL(11)
49PAT ; patient info
50 S IBPMAILN=$G(^DGCR(399,+IBIFN,"M")),IBFL(13)=$P(IBPMAILN,U,10)
51 S DFN=$P(IBCBILL,U,2) D DEM^VADPT
52 S IBFL(12)=VADM(1),IBFL(15)=$P(VADM(5),U,1) I IBFL(15)="" S IBFL(15)="U"
53 S IBFL(14)="00000000" I +VADM(3) S IBFL(14)=$$DATEY(+VADM(3))
54 ;S IBFL(14)=$S(+VADM(3):VADM(3),1:"0000000"),IBFL(14)=$$DATE(IBFL(14))
55 S IBX=$P(VADM(10),U,1)
56 S IBFL(16)=$S(IBX=1:"D",IBX=2:"M",IBX=4:"W",IBX=5:"X",IBX=6:"S",1:"U")
57 ;test to see if inpatient with a ptf#, if so use admission date
58 S IBX=0,IBINPAT=0 I $P(IBCBILL,U,5)<3 S IBINPAT=1 I +$P(IBCBILL,U,8) S IBX=$P($G(^DGPT(+$P(IBCBILL,U,8),0)),U,2)
59 I 'IBX S IBX=$P(IBCBILL,U,3)
60 S IBFL(17)=$$DATE(IBX),IBFL(18)=$$TIME(IBX) I IBFL(18)="" S IBFL(18)=99
61 ;
6219 ; type of admission if outpatient leave blank
63 S IBFL(19)="" I +IBINPAT S IBFL(19)=$S(+$P(IBSTATE,U,8):$P(IBSTATE,U,8),1:9)
6420 ; source of admission
65 S IBFL(20)="" I +IBINPAT S IBFL(20)=$S(+$P(IBSTATE,U,9):$P(IBSTATE,U,9),1:9)
6621 ; discharge hour: ptf (45,70), non-va (399,16), 99
67 S IBFL(21)="" I +IBINPAT S IBX=+$G(^DGPT(+$P(IBCBILL,U,8),70)) D
68 . S IBX=$S(+IBX:IBX,1:$P(IBCBILL,U,16)) S IBFL(21)=$$TIME(IBX) I IBFL(21)="" S IBFL(21)=99
6922 ;
70 D ^IBCF31,^IBCF32,^IBCF33,^IBCF3P
71 ;
72 ;set print status
73 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
74 D BSTAT^IBCDC(IBIFN) ; remove from AB list
75 ;
76EXIT K IBX,IBY,IBI,IBJ,IBCINSN,IBCBILL,IBSIGN,IBINPAT,IBSTATE,IBPMAILN,IBMAIL1,IBCBCOMM,IBCU2,IBCUF3,IBCUF31,IB,VADM,VA,VAERR,IBPG,IBFL,IBNOCHG,X,Y
77 K:'$D(IBXIEN) ^TMP($J)
78 Q
79 ;
80DATE(X) ;returns date in form format MMDDYY
81 Q $$DATE^IBCF2($G(X),,1)
82 ;
83DATEY(X) ;returns date in form format MMDDYYYY
84 Q $$DATE^IBCF2($G(X),1,1)
85 ;
86TIME(X) ;returns hour stripped from date
87 S X=$E($P($G(X),".",2),1,2) I X'="" S:+X=24 X="00" S X=X_"0"
88 Q $E(X,1,2)
89 ;
90SPLIT(FLN,LINES,MAXCH,STRG) ;sets the string broken into lines that will fit in the FL block, in IBFL(FLN,x)=strg where max x=LINES
91 ;specific for the multi line fields where the first line is 1 char less that the rest and is optional
92 ;assumes that the first line length is 1-MAXCH and should be used last
93 N CNT,IBX S CNT=1,STRG=$G(STRG),MAXCH=+$G(MAXCH) I '$G(FLN)!'$G(LINES) W "NO SOMETHING" Q
94 I $L(STRG)'>((LINES-1)*MAXCH) S IBFL(FLN,CNT)="",CNT=CNT+1 Q:CNT>LINES
95 I CNT=1 S IBFL(FLN,CNT)=$E(STRG,1,(MAXCH-1)),STRG=$E(STRG,MAXCH,999),CNT=CNT+1 Q:CNT>LINES
96 F S IBFL(FLN,CNT)=$E(STRG,1,MAXCH),STRG=$E(STRG,(MAXCH+1),999),CNT=CNT+1 Q:CNT>LINES
97 Q
Note: See TracBrowser for help on using the repository browser.