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

IBCF12 ;ALB/AAS - PRINT BILL CONT. ;24 MAY 90
 ;;2.0;INTEGRATED BILLING;**133,210**;21-MAR-94
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
 ;MAP TO DGCRP2
 ;
 ;Build ^Utility array of data to print in Block 20
 ;   Print Medicare statment on bottom 4 of 23 lines
 ;   Starting from top print the following, starting and finishing on
 ;     same page.
 ;   Print Revenue codes and subtotal
 ;   Print Additional CPT/ICD codes
 ;   Print offset and totals
 ;   Print Opt visit dates
 ;
 ;^Utility(...)=free text^pointer to rev or date of additional code^additional code variable pointer^"c" if additional code^executable code
 ;             =null ;blank line
% ;
 K ^UTILITY($J) S DGLCNT=0,DGSM=1 D SM^IBCU I 'DGSM D
 .;  -dgsm=1 print medicare statement
 .;  -dgsm=2 print NSC statement
 .;  -dgsm=3 print both statements
 .S DGRNODE=$G(^DGCR(399.3,$P(^DGCR(399,IBIFN,0),"^",7),0))
 .I $P(^DGCR(399,IBIFN,0),"^",11)="i",$P(DGRNODE,"^",8) S DGSM=1
 .I $P(DGRNODE,"^",9) S DGSM=DGSM+2
 .Q
 D ^IBCF14:DGSM
 D REVCOD
 D TOTAL
 D ADDCOD:$O(^DGCR(399,IBIFN,"CP",0))
 D OPVIS:$O(^DGCR(399,IBIFN,"OP",0))
 I DGLCNT<18 D FILL
 S DGCNT=0,DGPAG=1,DGTOTPAG=DGLCNT/23 S:$P(DGTOTPAG,".",2) DGTOTPAG=DGTOTPAG\1+1
 Q
 ;
REVCOD ;I $D(IBIP) S X=IBLS_" DAY"_$S(IBLS>1:"S ",1:" ")_$S(IBBS'=IBU:IBBS,1:"INPATIENT CARE") D SET
 I $D(IBIP) S X=IBLS_" DAY"_$S(IBLS>1:"S ",1:" ")_"INPATIENT CARE" D SET
 S X="" D SET
 S DGBS=""
 F I=0:0 S DGBS=$O(^DGCR(399,IBIFN,"RC","ABS",DGBS)) Q:'DGBS  I $D(^DGCR(399.1,DGBS,0)) S X=$P(^DGCR(399.1,DGBS,0),"^") D SET,RCODE
 ;
 ; -loop thru all REV CODES and print those with no bedsection
 S DGCNT=0,DGDA=0 F I=0:0 S DGDA=$O(^DGCR(399,IBIFN,"RC",DGDA)) Q:'DGDA  I $D(^(DGDA,0)),'$P(^(0),U,5) S X="^"_DGDA D SET
 S X="^^^^W !,""SUBTOTAL"",?39,$S(IB(""U1"")']"""":"""",$P(IB(""U1""),U,1)]"""":$J($P(IB(""U1""),U,1),9,2),1:$J(0,9,2))" D SET
 Q
 ;
 ;Input: DGBS - bedsection, IBIFN - Bill/Claim
RCODE ;Find revenue codes sorted by bedsection
 N DGRV,DGDA,IBCODE
 S DGRV=0 F  S DGRV=$O(^DGCR(399,IBIFN,"RC","ABS",DGBS,DGRV)) Q:'DGRV  D
 . S DGDA=0 F  S DGDA=$O(^DGCR(399,IBIFN,"RC","ABS",DGBS,DGRV,DGDA)) Q:'DGDA  D
 .. S X=U_DGDA D SET
 .. S IBCODE=$P($G(^DGCR(399,IBIFN,"RC",DGDA,0)),U,6) D:IBCODE>0
 ... S X="          Procedure:    "_$P($$CPT^IBACSV(IBCODE),U)
 ... D SET
 Q
ADDCOD ;Find additional codes
 Q:'$D(IBPROC)#2  Q:IBPROC<4
 D RSPACE
 I DGRSPAC<(IBPROC-2) D FILL
 S X="" D SET
 S X="ADDITIONAL PROCEDURE CODES:" D SET
 S J="" F I=1:1 S J=$O(IBPROC(J)) Q:'J  I I>3 S X="^"_$P(IBPROC(J),"^",2)_"^"_$P(IBPROC(J),"^")_"^C" D SET
 Q
 ;
TOTAL ;Find offsets and Totals
 D RSPACE
 I DGRSPAC<$S($P(IB("U1"),"^",2):4,1:2) D FILL
 S X="" D SET
 I $P(IB("U1"),"^",2) S X="^^^^W !,""LESS "",$P(IB(""U1""),""^"",3),?39,$J($P(IB(""U1""),""^"",2),9,2)" D SET S X="" D SET
 S X="^^^^W !,""TOTAL"",?31,$S(+$P(IBEPAR(1),""^"",10):""001"",1:""""),?39,$J($P(IB(""U1""),""^"")-$P(IB(""U1""),""^"",2),9,2)" D SET
 Q
 ;
OPVIS ;Find outpatient Visit dates
 D RSPACE
 S DGCNT=0 F I=0:0 S I=$O(^DGCR(399,IBIFN,"OP",I)) Q:'I  S DGCNT=DGCNT+1
 S DGCNT=DGCNT/3 I $P(DGCNT,".",2)]"" S DGCNT=DGCNT\1+1
 I DGRSPAC<(DGCNT+1) D FILL
 S X="" D SET
 S X="OP VISIT DATE(S) BILLED              "
 S IB01=0 F IB02=1:1 S IB01=$O(^DGCR(399,IBIFN,"OP",IB01)) Q:'IB01  S Y=IB01 X ^DD("DD") S X=X_Y_$S($O(^DGCR(399,IBIFN,"OP",IB01)):", ",1:"") I '(IB02#3) D SET S X="                                     "
 I (IB02-1)#3 D SET
 K IB01,IB02
 Q
 ;
SET S DGLCNT=DGLCNT+1
 I DGLCNT<24,DGSM,DGLCNT+$S(DGSM=1:5,DGSM=2:2,1:8)>23 S DGLCNT=24
 G:$D(^UTILITY($J,"IB-RC",DGLCNT)) SET
 S ^UTILITY($J,"IB-RC",DGLCNT)=X Q
 Q
 ;
RSPACE ;Find remaining blank lines
 S DGRSPAC=$S(DGLCNT<24:$S(DGSM=1:18,DGSM=2:21,DGSM=3:15,1:23)-DGLCNT,DGLCNT<47:46-DGLCNT,DGLCNT<70:69-DGLCNT,DGLCNT<93:92-DGLCNT,DGLCNT<116:115,1:138)
 Q
FILL ;fill space with blank lines so all will fit on page
 F I=0:0 Q:($S(DGSM=1&(DGLCNT=18):1,DGSM=2&(DGLCNT=21):1,DGSM=3&(DGLCNT=15):1,1:0))!('(DGLCNT#23))  S X="" D SET
 Q