- IBOMTP1 ;ALB/CPM - MEANS TEST BILLING PROFILE (CON'T);10-DEC-91
- ;;2.0;INTEGRATED BILLING;**15,153,176,183,651,656,678,747**;21-MAR-94;Build 2
- ;; Per VHA Directive 10-93-142, this routine should not be modified
- ;
- N IBLEG,IBCHK
- ;***
- ;S XRTL=$ZU(0),XRTN="IBOMTP1-2" D T0^%ZOSV ;start rt clock
- ; Begin compilation. Start with billing clocks.
- S Y=-(IBEDT+.1),X=0 F Q:-Y<IBBDT S Y=$O(^IBE(351,"AIVDT",IBDFN,Y)) Q:'Y F S X=$O(^IBE(351,"AIVDT",IBDFN,Y,X)) Q:'X S:$P($G(^IBE(351,X,0)),U,4)'=3 ^TMP($J,"IBOMTP",-Y,"C")=""
- ;
- ; Get O/P visits from file #399.
- S X1=IBBDT,X2=-1 D C^%DTC S Y=X
- F S Y=$O(^DGCR(399,"AOPV",IBDFN,Y)) Q:'Y!(Y>IBEDT) D
- . S IBDA=0 F S IBDA=$O(^DGCR(399,"AOPV",IBDFN,Y,IBDA)) Q:'IBDA D
- .. I $D(^DGCR(399,+IBDA,0)),'$P($G(^("S")),U,16),$P($G(^DGCR(399.3,+$P(^(0),U,7),0)),U)["MEANS" S ^TMP($J,"IBOMTP",Y,"M"_IBDA)=""
- ;
- ;IB*2.0*678 - add seconds to IBEDT (IBEDTP1) and use that for the End Date range
- S IBEDTP1=IBEDT+.999999
- ; Get the rest of the charges from file #350.
- S Y="" F S Y=$O(^IB("AFDT",IBDFN,Y)) Q:'Y I -Y'>IBEDTP1 S Y1=0 F S Y1=$O(^IB("AFDT",IBDFN,Y,Y1)) Q:'Y1 D
- . S (IBDA,IBCHK)=0 F S IBDA=$O(^IB("AF",Y1,IBDA)) Q:'IBDA D
- .. Q:'$D(^IB(IBDA,0))
- .. S IBX=^IB(IBDA,0)
- .. Q:$P(IBX,U,8)["ADMISSION"
- .. I $P(IBX,U,15)<IBBDT!($P(IBX,U,14)>IBEDTP1) Q
- .. N Y,Y1
- .. ; Action type. We don't include LTC actions to the report
- .. I $P(IBX,U,3) I $$ACTNM^IBOUTL(+$P(IBX,U,3))["LTC " Q ; Exclude LTC action type
- .. S ^TMP($J,"IBOMTP",+$P(IBX,U,14),"I"_IBDA)="",IBCHK=1
- . Q:IBCHK ;If an entry already found its not a pharmacy RX
- . S IBX=$G(^IB(Y1,0))
- . S IBATYP=$P(IBX,U,3),IBBLG=$$GET1^DIQ(350.1,IBATYP_",",.11,"I")
- . I IBBLG=5 D ;Is this an RX copay
- .. I $P(IBX,U,15)<IBBDT!($P(IBX,U,14)>IBEDTP1) Q ;Check to ensure the visit is in the correct search range
- .. S ^TMP($J,"IBOMTP",+$P(IBX,U,14),"I"_Y1)="" ;Store in reporting array.
- ;
- ; Print report.
- S IBLEG=0 ; Legend not required
- D NOW^%DTC S IBHDT=$$DAT2^IBOUTL($E(%,1,12))
- S IBLINE="",$P(IBLINE,"-",IOM+1)="",(IBPAG,IBCHGT,IBQUIT)=0
- S IBPT=$$PT^IBEFUNC(IBDFN)
- S IBH="Means Test Billing Profile for "_$P(IBPT,U) D HDR ; IB*2.0*747
- I '$D(^TMP($J,"IBOMTP")) W !,"This patient has no Means Test bills." D PAUSE^IBOUTL G END
- ; - first, print detail lines
- S IBD="" F S IBD=$O(^TMP($J,"IBOMTP",IBD)) Q:'IBD D G:IBQUIT END
- . S IBTY="" F S IBTY=$O(^TMP($J,"IBOMTP",IBD,IBTY)) Q:IBTY="" D Q:IBQUIT
- .. I $Y>(IOSL-5) D PAUSE^IBOUTL Q:IBQUIT D HDR
- .. W !,$$DAT1^IBOUTL(IBD)
- .. I IBTY="C" W ?12,"Begin Means Test Billing Clock" Q
- .. S IBDA=+$E(IBTY,2,99),IBD0=$S($E(IBTY)="M":$G(^DGCR(399,IBDA,0)),1:$G(^IB(IBDA,0))),IBSEQ=0
- .. I $E(IBTY)="I" S IBSEQ=$P($G(^IBE(350.1,+$P(IBD0,U,3),0)),U,5)
- .. W ?14,$S($E(IBTY)="M":"OPT COPAYMENT (UB-82)",1:$$ACTNM^IBOUTL(+$P(IBD0,U,3)))
- .. W ?44,$S($E(IBTY)="M":$P(IBD0,U),1:$$STAT())
- .. I $E(IBTY)="I",$P(IBD0,U,14)'=$P(IBD0,U,15) W ?54,$$DAT1^IBOUTL($P(IBD0,U,15))
- .. I $E(IBTY)="M" S X=+$O(^DGCR(399,IBDA,"RC","B",500,0)),IBCHG=+$P($G(^DGCR(399,IBDA,"RC",X,0)),U,2)
- .. E S IBCHG=+$P(IBD0,U,7)
- .. I IBSEQ=2 S IBCHG=-IBCHG
- .. I $E(IBTY)="I",$P(IBD0,U,11)="",$P($G(^IBE(350.21,+$P(IBD0,U,5),0)),U,5) S IBCHG=0
- .. S X=IBCHG,X2="2$",X3=10 D COMMA^%DTC W ?65,X
- .. I $P(IBD0,U,21) W " *" S IBLEG=1 ;Print legend at the bottom
- .. S IBCHGT=IBCHGT+IBCHG
- .. I IBSEQ=2!($P(IBD0,U,11)=""&($P($G(^IBE(350.21,+$P(IBD0,U,5),0)),U,5))) W !?5,"Charge Removal Reason: ",$S($D(^IBE(350.3,+$P(IBD0,U,10),0)):$P(^(0),U),1:"UNKNOWN")
- ; - print totals line
- I ($Y-IBLEG)>(IOSL-5) D LEGEND,PAUSE^IBOUTL G:IBQUIT END D HDR
- W !?63,"-----------" S X=IBCHGT,X2="2$",X3=12 D COMMA^%DTC W !?63,X
- D LEGEND,PAUSE^IBOUTL
- ; - close device and quit
- END K ^TMP($J)
- ;***
- ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOMTP1" D T1^%ZOSV ;stop rt clock
- I $D(ZTQUEUED) S ZTREQ="@" Q
- K IBJ,IBD,IBH,IBHDT,IBTY,IBDA,IBD0,IBSEQ,IBQUIT,IBCHG,IBCHGT,IBPAG,IBLINE,IBX,IBPT,X,X2,X3,Y,Y1
- D ^%ZISC Q
- ;
- ;
- HDR ; Print header.
- S IBLEG=0
- I $E(IOST,1,2)["C-"!(IBPAG) W @IOF,*13
- S IBPAG=IBPAG+1 W ?(80-$L(IBH)\2),IBH
- W !,"From ",$$DAT1^IBOUTL(IBBDT)," through ",$$DAT1^IBOUTL(IBEDT)
- W ?IOM-36,IBHDT,?IOM-9,"Page: ",IBPAG
- W !,"BILL DATE BILL TYPE",?44,"BILL # BILL TO TOT CHARGE"
- W !,IBLINE,! Q
- ;
- STAT() ; Display bill number or status
- N IBSTAT S IBSTAT=$G(^IBE(350.21,+$P(IBD0,U,5),0))
- Q $S($P(IBSTAT,U,6):$$HLD(+$P(IBD0,U,5)),$P(IBD0,U,5)=99:"Converted",$P(IBD0,U,11)]"":$P($P(IBD0,U,11),"-",2),$P(IBSTAT,U,5):"Cancelled",1:"Pending")
- ;
- HLD(STAT) ; Return an 'on hold' status string
- Q "Hold "_$S(STAT=20:"Rate",STAT=21:"Rev",1:"Ins")
- ;
- LEGEND I $G(IBLEG) W !," '*' - Geographic Means Test rates"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOMTP1 4782 printed Apr 23, 2025@18:40:33 Page 2
- IBOMTP1 ;ALB/CPM - MEANS TEST BILLING PROFILE (CON'T);10-DEC-91
- +1 ;;2.0;INTEGRATED BILLING;**15,153,176,183,651,656,678,747**;21-MAR-94;Build 2
- +2 ;; Per VHA Directive 10-93-142, this routine should not be modified
- +3 ;
- +4 NEW IBLEG,IBCHK
- +5 ;***
- +6 ;S XRTL=$ZU(0),XRTN="IBOMTP1-2" D T0^%ZOSV ;start rt clock
- +7 ; Begin compilation. Start with billing clocks.
- +8 SET Y=-(IBEDT+.1)
- SET X=0
- FOR
- if -Y<IBBDT
- QUIT
- SET Y=$ORDER(^IBE(351,"AIVDT",IBDFN,Y))
- if 'Y
- QUIT
- FOR
- SET X=$ORDER(^IBE(351,"AIVDT",IBDFN,Y,X))
- if 'X
- QUIT
- if $PIECE($GET(^IBE(351,X,0)),U,4)'=3
- SET ^TMP($JOB,"IBOMTP",-Y,"C")=""
- +9 ;
- +10 ; Get O/P visits from file #399.
- +11 SET X1=IBBDT
- SET X2=-1
- DO C^%DTC
- SET Y=X
- +12 FOR
- SET Y=$ORDER(^DGCR(399,"AOPV",IBDFN,Y))
- if 'Y!(Y>IBEDT)
- QUIT
- Begin DoDot:1
- +13 SET IBDA=0
- FOR
- SET IBDA=$ORDER(^DGCR(399,"AOPV",IBDFN,Y,IBDA))
- if 'IBDA
- QUIT
- Begin DoDot:2
- +14 IF $DATA(^DGCR(399,+IBDA,0))
- IF '$PIECE($GET(^("S")),U,16)
- IF $PIECE($GET(^DGCR(399.3,+$PIECE(^(0),U,7),0)),U)["MEANS"
- SET ^TMP($JOB,"IBOMTP",Y,"M"_IBDA)=""
- End DoDot:2
- End DoDot:1
- +15 ;
- +16 ;IB*2.0*678 - add seconds to IBEDT (IBEDTP1) and use that for the End Date range
- +17 SET IBEDTP1=IBEDT+.999999
- +18 ; Get the rest of the charges from file #350.
- +19 SET Y=""
- FOR
- SET Y=$ORDER(^IB("AFDT",IBDFN,Y))
- if 'Y
- QUIT
- IF -Y'>IBEDTP1
- SET Y1=0
- FOR
- SET Y1=$ORDER(^IB("AFDT",IBDFN,Y,Y1))
- if 'Y1
- QUIT
- Begin DoDot:1
- +20 SET (IBDA,IBCHK)=0
- FOR
- SET IBDA=$ORDER(^IB("AF",Y1,IBDA))
- if 'IBDA
- QUIT
- Begin DoDot:2
- +21 if '$DATA(^IB(IBDA,0))
- QUIT
- +22 SET IBX=^IB(IBDA,0)
- +23 if $PIECE(IBX,U,8)["ADMISSION"
- QUIT
- +24 IF $PIECE(IBX,U,15)<IBBDT!($PIECE(IBX,U,14)>IBEDTP1)
- QUIT
- +25 NEW Y,Y1
- +26 ; Action type. We don't include LTC actions to the report
- +27 ; Exclude LTC action type
- IF $PIECE(IBX,U,3)
- IF $$ACTNM^IBOUTL(+$PIECE(IBX,U,3))["LTC "
- QUIT
- +28 SET ^TMP($JOB,"IBOMTP",+$PIECE(IBX,U,14),"I"_IBDA)=""
- SET IBCHK=1
- End DoDot:2
- +29 ;If an entry already found its not a pharmacy RX
- if IBCHK
- QUIT
- +30 SET IBX=$GET(^IB(Y1,0))
- +31 SET IBATYP=$PIECE(IBX,U,3)
- SET IBBLG=$$GET1^DIQ(350.1,IBATYP_",",.11,"I")
- +32 ;Is this an RX copay
- IF IBBLG=5
- Begin DoDot:2
- +33 ;Check to ensure the visit is in the correct search range
- IF $PIECE(IBX,U,15)<IBBDT!($PIECE(IBX,U,14)>IBEDTP1)
- QUIT
- +34 ;Store in reporting array.
- SET ^TMP($JOB,"IBOMTP",+$PIECE(IBX,U,14),"I"_Y1)=""
- End DoDot:2
- End DoDot:1
- +35 ;
- +36 ; Print report.
- +37 ; Legend not required
- SET IBLEG=0
- +38 DO NOW^%DTC
- SET IBHDT=$$DAT2^IBOUTL($EXTRACT(%,1,12))
- +39 SET IBLINE=""
- SET $PIECE(IBLINE,"-",IOM+1)=""
- SET (IBPAG,IBCHGT,IBQUIT)=0
- +40 SET IBPT=$$PT^IBEFUNC(IBDFN)
- +41 ; IB*2.0*747
- SET IBH="Means Test Billing Profile for "_$PIECE(IBPT,U)
- DO HDR
- +42 IF '$DATA(^TMP($JOB,"IBOMTP"))
- WRITE !,"This patient has no Means Test bills."
- DO PAUSE^IBOUTL
- GOTO END
- +43 ; - first, print detail lines
- +44 SET IBD=""
- FOR
- SET IBD=$ORDER(^TMP($JOB,"IBOMTP",IBD))
- if 'IBD
- QUIT
- Begin DoDot:1
- +45 SET IBTY=""
- FOR
- SET IBTY=$ORDER(^TMP($JOB,"IBOMTP",IBD,IBTY))
- if IBTY=""
- QUIT
- Begin DoDot:2
- +46 IF $Y>(IOSL-5)
- DO PAUSE^IBOUTL
- if IBQUIT
- QUIT
- DO HDR
- +47 WRITE !,$$DAT1^IBOUTL(IBD)
- +48 IF IBTY="C"
- WRITE ?12,"Begin Means Test Billing Clock"
- QUIT
- +49 SET IBDA=+$EXTRACT(IBTY,2,99)
- SET IBD0=$SELECT($EXTRACT(IBTY)="M":$GET(^DGCR(399,IBDA,0)),1:$GET(^IB(IBDA,0)))
- SET IBSEQ=0
- +50 IF $EXTRACT(IBTY)="I"
- SET IBSEQ=$PIECE($GET(^IBE(350.1,+$PIECE(IBD0,U,3),0)),U,5)
- +51 WRITE ?14,$SELECT($EXTRACT(IBTY)="M":"OPT COPAYMENT (UB-82)",1:$$ACTNM^IBOUTL(+$PIECE(IBD0,U,3)))
- +52 WRITE ?44,$SELECT($EXTRACT(IBTY)="M":$PIECE(IBD0,U),1:$$STAT())
- +53 IF $EXTRACT(IBTY)="I"
- IF $PIECE(IBD0,U,14)'=$PIECE(IBD0,U,15)
- WRITE ?54,$$DAT1^IBOUTL($PIECE(IBD0,U,15))
- +54 IF $EXTRACT(IBTY)="M"
- SET X=+$ORDER(^DGCR(399,IBDA,"RC","B",500,0))
- SET IBCHG=+$PIECE($GET(^DGCR(399,IBDA,"RC",X,0)),U,2)
- +55 IF '$TEST
- SET IBCHG=+$PIECE(IBD0,U,7)
- +56 IF IBSEQ=2
- SET IBCHG=-IBCHG
- +57 IF $EXTRACT(IBTY)="I"
- IF $PIECE(IBD0,U,11)=""
- IF $PIECE($GET(^IBE(350.21,+$PIECE(IBD0,U,5),0)),U,5)
- SET IBCHG=0
- +58 SET X=IBCHG
- SET X2="2$"
- SET X3=10
- DO COMMA^%DTC
- WRITE ?65,X
- +59 ;Print legend at the bottom
- IF $PIECE(IBD0,U,21)
- WRITE " *"
- SET IBLEG=1
- +60 SET IBCHGT=IBCHGT+IBCHG
- +61 IF IBSEQ=2!($PIECE(IBD0,U,11)=""&($PIECE($GET(^IBE(350.21,+$PIECE(IBD0,U,5),0)),U,5)))
- WRITE !?5,"Charge Removal Reason: ",$SELECT($DATA(^IBE(350.3,+$PIECE(IBD0,U,10),0)):$PIECE(^(0),U),1:"UNKNOWN")
- End DoDot:2
- if IBQUIT
- QUIT
- End DoDot:1
- if IBQUIT
- GOTO END
- +62 ; - print totals line
- +63 IF ($Y-IBLEG)>(IOSL-5)
- DO LEGEND
- DO PAUSE^IBOUTL
- if IBQUIT
- GOTO END
- DO HDR
- +64 WRITE !?63,"-----------"
- SET X=IBCHGT
- SET X2="2$"
- SET X3=12
- DO COMMA^%DTC
- WRITE !?63,X
- +65 DO LEGEND
- DO PAUSE^IBOUTL
- +66 ; - close device and quit
- END KILL ^TMP($JOB)
- +1 ;***
- +2 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOMTP1" D T1^%ZOSV ;stop rt clock
- +3 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- QUIT
- +4 KILL IBJ,IBD,IBH,IBHDT,IBTY,IBDA,IBD0,IBSEQ,IBQUIT,IBCHG,IBCHGT,IBPAG,IBLINE,IBX,IBPT,X,X2,X3,Y,Y1
- +5 DO ^%ZISC
- QUIT
- +6 ;
- +7 ;
- HDR ; Print header.
- +1 SET IBLEG=0
- +2 IF $EXTRACT(IOST,1,2)["C-"!(IBPAG)
- WRITE @IOF,*13
- +3 SET IBPAG=IBPAG+1
- WRITE ?(80-$LENGTH(IBH)\2),IBH
- +4 WRITE !,"From ",$$DAT1^IBOUTL(IBBDT)," through ",$$DAT1^IBOUTL(IBEDT)
- +5 WRITE ?IOM-36,IBHDT,?IOM-9,"Page: ",IBPAG
- +6 WRITE !,"BILL DATE BILL TYPE",?44,"BILL # BILL TO TOT CHARGE"
- +7 WRITE !,IBLINE,!
- QUIT
- +8 ;
- STAT() ; Display bill number or status
- +1 NEW IBSTAT
- SET IBSTAT=$GET(^IBE(350.21,+$PIECE(IBD0,U,5),0))
- +2 QUIT $SELECT($PIECE(IBSTAT,U,6):$$HLD(+$PIECE(IBD0,U,5)),$PIECE(IBD0,U,5)=99:"Converted",$PIECE(IBD0,U,11)]"":$PIECE($PIECE(IBD0,U,11),"-",2),$PIECE(IBSTAT,U,5):"Cancelled",1:"Pending")
- +3 ;
- HLD(STAT) ; Return an 'on hold' status string
- +1 QUIT "Hold "_$SELECT(STAT=20:"Rate",STAT=21:"Rev",1:"Ins")
- +2 ;
- LEGEND IF $GET(IBLEG)
- WRITE !," '*' - Geographic Means Test rates"
- +1 QUIT
