- IBOMTC1 ;ALB/CPM-BILLING ACTIVITY LIST (CON'T) ; 09-JAN-92
- ;;2.0;INTEGRATED BILLING;**145,176,618**;21-MAR-94;Build 61
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ;***
- ;S XRTL=$ZU(0),XRTN="IBOMTC-2" D T0^%ZOSV ;start rt clock
- ; Select charges from file #350.
- K ^TMP($J,"IBPHT")
- N IBTYPE,IBIEN ; Patch IB*2.0*618
- S DFN="" F S DFN=$O(^IB("AFDT",DFN)) Q:'DFN S IBHEART=$$PH(DFN) D:'$G(IBPURPHT)!($G(IBPURPHT)&(IBHEART))
- . S EVDT=-(IBEDT+.99) F S EVDT=$O(^IB("AFDT",DFN,EVDT)) Q:'EVDT D
- .. S EVDA=0 F S EVDA=$O(^IB("AFDT",DFN,EVDT,EVDA)) Q:'EVDA D
- ... S IBDA=0 F IBCNT=1:1 S IBDA=$O(^IB("AF",EVDA,IBDA)) Q:'IBDA D
- .... Q:'$D(^IB(IBDA,0)) S IBD0=^(0)
- .... Q:$P(IBD0,"^",8)["ADMISSION"
- .... I $P(IBD0,"^",15)<IBBDT!($P(IBD0,"^",14)>IBEDT) Q
- .... S NAM=$P($G(^DPT(DFN,0)),"^") S:NAM="" NAM="UNKNOWN"
- .... S ^TMP($J,"IBOMTC",NAM_"@@"_DFN,+$P(IBD0,"^",14),IBDA)=""
- .... I IBHEART S ^TMP($J,"IBPHT",NAM_"@@"_DFN)=""
- ;
- ; Print report.
- D NOW^%DTC S IBHDT=$$DAT2^IBOUTL($E(%,1,12))
- S IBLINE="",$P(IBLINE,"-",IOM+1)="",(IBPAG,IBQUIT)=0 D HDR G:IBQUIT END
- I '$D(^TMP($J,"IBOMTC")) S IBX=$S($G(IBPURPHT):"Purple Heart Recipients",1:"Bills") W !!,"There are no "_IBX_" for this date range." G END
- ;
- S NAM="" F S NAM=$O(^TMP($J,"IBOMTC",NAM)) Q:NAM="" D Q:IBQUIT
- . S IBPT=$$PT^IBEFUNC($P(NAM,"@@",2))
- . I $Y>(IOSL-5) D PHT,PAUSE^IBOUTL Q:IBQUIT D HDR Q:IBQUIT
- . W !,$S($D(^TMP($J,"IBPHT",NAM)):"*",1:" ")_$E($P(IBPT,"^"),1,9),?11,$P(IBPT,"^",3)
- . S IBDT="" F S IBDT=$O(^TMP($J,"IBOMTC",NAM,IBDT)) Q:'IBDT D Q:IBQUIT
- .. S IBDA="" F S IBDA=$O(^TMP($J,"IBOMTC",NAM,IBDT,IBDA)) Q:'IBDA D Q:IBQUIT
- ... I $Y>(IOSL-4) D PHT,PAUSE^IBOUTL Q:IBQUIT D HDR Q:IBQUIT W !,$S($D(^TMP($J,"IBPHT",NAM)):"*",1:" ")_$E($P(IBPT,"^"),1,9),?11,$P(IBPT,"^",3)
- ... S IBD0=$G(^IB(+IBDA,0)) Q:'IBD0
- ... S X=$P($G(^IBE(350.1,+$P(IBD0,"^",3),0)),"^")
- ... ; begin of Patch IB*2.0*618 - added community care - action types
- ... S IBIEN=$P(IBD0,"^",3),IBTYPE=$$GETATYPE(IBIEN)
- ... W ?17,IBTYPE
- ... ; end of Patch IB*2.0*618
- ... W ?35,$E($P($G(^IBE(350.21,+$P(IBD0,"^",5),0)),"^",2),1,11)
- ... W ?47,$$DAT1^IBOUTL($P(IBD0,"^",14)),?57,$$DAT1^IBOUTL($P(IBD0,"^",15))
- ... W ?66,$J($P(IBD0,"^",6),3)
- ... S X=$P(IBD0,"^",7),X2="2$",X3=10 D COMMA^%DTC W ?70,X,!
- ;
- ; - close device and quit
- END D:'IBQUIT PHT,PAUSE^IBOUTL K ^TMP($J,"IBOMTC"),^TMP($J,"IBPHT")
- ;***
- ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOMTC1" D T1^%ZOSV ;stop rt clock
- I $D(ZTQUEUED) S ZTREQ="@" Q
- K NAM,DFN,EVDA,EVDT,IBD0,IBDA,IBDT,IBJ,IBQUIT,IBLINE,IBHDT,IBHEART,IBN,IBPAG,IBPT,IBCNT,X,X2,X3
- D ^%ZISC Q
- ;
- ;
- HDR ; Print header.
- I $E(IOST,1,2)["C-"!(IBPAG) W @IOF
- S IBPAG=IBPAG+1 W !,IBDESC,?IOM-35,IBHDT,?IOM-9,"Page: ",IBPAG
- I $G(IBPURPHT) W !," * This report is being generated for Purple Heart Patients only *"
- W !,"Charges from ",$$DAT1^IBOUTL(IBBDT)," through ",$$DAT1^IBOUTL(IBEDT)
- W !,"PATIENT/ID",?17,"DESCRIPTION",?35,"STATUS",?49,"FROM",?60,"TO",?66,"UNITS",?72,"CHARGE"
- W !,IBLINE
- S IBQUIT=$$STOP^IBOUTL("Billing Activity List")
- Q
- PHT ;ADDS the footnote of * Purple Heart Recipient to the report.
- W !,?10,"* Purple Heart Recipient"
- Q
- ;
- ;
- PH(DFN) ;Call to find out if a patient is a Purple Heart recipient.
- ; DFN - patient's DFN
- ;
- ; Output - 1 means PH Indicator is "Yes"
- ; 0 means PH Indicator is not "yes" (either "no" or null)
- I '$D(^DPT(+$G(DFN),0)) Q 0
- N IBPHT,VASV,VAERR
- D SVC^VADPT
- S IBPHT=$P($G(VASV(9,1)),"^",1)
- I IBPHT'=3 S IBPHT=0
- Q IBPHT
- ;
- GETATYPE(IBIEN) ; Patch IB*2.0*618 - added community care - action types
- S IBTYPE=$P(^IBE(350.1,IBIEN,0),"^") I $E(IBTYPE,1,2)="DG" Q $E($P(IBTYPE," ",2,99),1,16)
- I $E(IBTYPE,1,3)="PSO" Q $E($P(IBTYPE," ",2,99),1,16)
- Q $E(IBTYPE,1,16)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOMTC1 3853 printed Mar 13, 2025@21:30:52 Page 2
- IBOMTC1 ;ALB/CPM-BILLING ACTIVITY LIST (CON'T) ; 09-JAN-92
- +1 ;;2.0;INTEGRATED BILLING;**145,176,618**;21-MAR-94;Build 61
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;***
- +5 ;S XRTL=$ZU(0),XRTN="IBOMTC-2" D T0^%ZOSV ;start rt clock
- +6 ; Select charges from file #350.
- +7 KILL ^TMP($JOB,"IBPHT")
- +8 ; Patch IB*2.0*618
- NEW IBTYPE,IBIEN
- +9 SET DFN=""
- FOR
- SET DFN=$ORDER(^IB("AFDT",DFN))
- if 'DFN
- QUIT
- SET IBHEART=$$PH(DFN)
- if '$GET(IBPURPHT)!($GET(IBPURPHT)&(IBHEART))
- Begin DoDot:1
- +10 SET EVDT=-(IBEDT+.99)
- FOR
- SET EVDT=$ORDER(^IB("AFDT",DFN,EVDT))
- if 'EVDT
- QUIT
- Begin DoDot:2
- +11 SET EVDA=0
- FOR
- SET EVDA=$ORDER(^IB("AFDT",DFN,EVDT,EVDA))
- if 'EVDA
- QUIT
- Begin DoDot:3
- +12 SET IBDA=0
- FOR IBCNT=1:1
- SET IBDA=$ORDER(^IB("AF",EVDA,IBDA))
- if 'IBDA
- QUIT
- Begin DoDot:4
- +13 if '$DATA(^IB(IBDA,0))
- QUIT
- SET IBD0=^(0)
- +14 if $PIECE(IBD0,"^",8)["ADMISSION"
- QUIT
- +15 IF $PIECE(IBD0,"^",15)<IBBDT!($PIECE(IBD0,"^",14)>IBEDT)
- QUIT
- +16 SET NAM=$PIECE($GET(^DPT(DFN,0)),"^")
- if NAM=""
- SET NAM="UNKNOWN"
- +17 SET ^TMP($JOB,"IBOMTC",NAM_"@@"_DFN,+$PIECE(IBD0,"^",14),IBDA)=""
- +18 IF IBHEART
- SET ^TMP($JOB,"IBPHT",NAM_"@@"_DFN)=""
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +19 ;
- +20 ; Print report.
- +21 DO NOW^%DTC
- SET IBHDT=$$DAT2^IBOUTL($EXTRACT(%,1,12))
- +22 SET IBLINE=""
- SET $PIECE(IBLINE,"-",IOM+1)=""
- SET (IBPAG,IBQUIT)=0
- DO HDR
- if IBQUIT
- GOTO END
- +23 IF '$DATA(^TMP($JOB,"IBOMTC"))
- SET IBX=$SELECT($GET(IBPURPHT):"Purple Heart Recipients",1:"Bills")
- WRITE !!,"There are no "_IBX_" for this date range."
- GOTO END
- +24 ;
- +25 SET NAM=""
- FOR
- SET NAM=$ORDER(^TMP($JOB,"IBOMTC",NAM))
- if NAM=""
- QUIT
- Begin DoDot:1
- +26 SET IBPT=$$PT^IBEFUNC($PIECE(NAM,"@@",2))
- +27 IF $Y>(IOSL-5)
- DO PHT
- DO PAUSE^IBOUTL
- if IBQUIT
- QUIT
- DO HDR
- if IBQUIT
- QUIT
- +28 WRITE !,$SELECT($DATA(^TMP($JOB,"IBPHT",NAM)):"*",1:" ")_$EXTRACT($PIECE(IBPT,"^"),1,9),?11,$PIECE(IBPT,"^",3)
- +29 SET IBDT=""
- FOR
- SET IBDT=$ORDER(^TMP($JOB,"IBOMTC",NAM,IBDT))
- if 'IBDT
- QUIT
- Begin DoDot:2
- +30 SET IBDA=""
- FOR
- SET IBDA=$ORDER(^TMP($JOB,"IBOMTC",NAM,IBDT,IBDA))
- if 'IBDA
- QUIT
- Begin DoDot:3
- +31 IF $Y>(IOSL-4)
- DO PHT
- DO PAUSE^IBOUTL
- if IBQUIT
- QUIT
- DO HDR
- if IBQUIT
- QUIT
- WRITE !,$SELECT($DATA(^TMP($JOB,"IBPHT",NAM)):"*",1:" ")_$EXTRACT($PIECE(IBPT,"^"),1,9),?11,$PIECE(IBPT,"^",3)
- +32 SET IBD0=$GET(^IB(+IBDA,0))
- if 'IBD0
- QUIT
- +33 SET X=$PIECE($GET(^IBE(350.1,+$PIECE(IBD0,"^",3),0)),"^")
- +34 ; begin of Patch IB*2.0*618 - added community care - action types
- +35 SET IBIEN=$PIECE(IBD0,"^",3)
- SET IBTYPE=$$GETATYPE(IBIEN)
- +36 WRITE ?17,IBTYPE
- +37 ; end of Patch IB*2.0*618
- +38 WRITE ?35,$EXTRACT($PIECE($GET(^IBE(350.21,+$PIECE(IBD0,"^",5),0)),"^",2),1,11)
- +39 WRITE ?47,$$DAT1^IBOUTL($PIECE(IBD0,"^",14)),?57,$$DAT1^IBOUTL($PIECE(IBD0,"^",15))
- +40 WRITE ?66,$JUSTIFY($PIECE(IBD0,"^",6),3)
- +41 SET X=$PIECE(IBD0,"^",7)
- SET X2="2$"
- SET X3=10
- DO COMMA^%DTC
- WRITE ?70,X,!
- End DoDot:3
- if IBQUIT
- QUIT
- End DoDot:2
- if IBQUIT
- QUIT
- End DoDot:1
- if IBQUIT
- QUIT
- +42 ;
- +43 ; - close device and quit
- END if 'IBQUIT
- DO PHT
- DO PAUSE^IBOUTL
- KILL ^TMP($JOB,"IBOMTC"),^TMP($JOB,"IBPHT")
- +1 ;***
- +2 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOMTC1" D T1^%ZOSV ;stop rt clock
- +3 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- QUIT
- +4 KILL NAM,DFN,EVDA,EVDT,IBD0,IBDA,IBDT,IBJ,IBQUIT,IBLINE,IBHDT,IBHEART,IBN,IBPAG,IBPT,IBCNT,X,X2,X3
- +5 DO ^%ZISC
- QUIT
- +6 ;
- +7 ;
- HDR ; Print header.
- +1 IF $EXTRACT(IOST,1,2)["C-"!(IBPAG)
- WRITE @IOF
- +2 SET IBPAG=IBPAG+1
- WRITE !,IBDESC,?IOM-35,IBHDT,?IOM-9,"Page: ",IBPAG
- +3 IF $GET(IBPURPHT)
- WRITE !," * This report is being generated for Purple Heart Patients only *"
- +4 WRITE !,"Charges from ",$$DAT1^IBOUTL(IBBDT)," through ",$$DAT1^IBOUTL(IBEDT)
- +5 WRITE !,"PATIENT/ID",?17,"DESCRIPTION",?35,"STATUS",?49,"FROM",?60,"TO",?66,"UNITS",?72,"CHARGE"
- +6 WRITE !,IBLINE
- +7 SET IBQUIT=$$STOP^IBOUTL("Billing Activity List")
- +8 QUIT
- PHT ;ADDS the footnote of * Purple Heart Recipient to the report.
- +1 WRITE !,?10,"* Purple Heart Recipient"
- +2 QUIT
- +3 ;
- +4 ;
- PH(DFN) ;Call to find out if a patient is a Purple Heart recipient.
- +1 ; DFN - patient's DFN
- +2 ;
- +3 ; Output - 1 means PH Indicator is "Yes"
- +4 ; 0 means PH Indicator is not "yes" (either "no" or null)
- +5 IF '$DATA(^DPT(+$GET(DFN),0))
- QUIT 0
- +6 NEW IBPHT,VASV,VAERR
- +7 DO SVC^VADPT
- +8 SET IBPHT=$PIECE($GET(VASV(9,1)),"^",1)
- +9 IF IBPHT'=3
- SET IBPHT=0
- +10 QUIT IBPHT
- +11 ;
- GETATYPE(IBIEN) ; Patch IB*2.0*618 - added community care - action types
- +1 SET IBTYPE=$PIECE(^IBE(350.1,IBIEN,0),"^")
- IF $EXTRACT(IBTYPE,1,2)="DG"
- QUIT $EXTRACT($PIECE(IBTYPE," ",2,99),1,16)
- +2 IF $EXTRACT(IBTYPE,1,3)="PSO"
- QUIT $EXTRACT($PIECE(IBTYPE," ",2,99),1,16)
- +3 QUIT $EXTRACT(IBTYPE,1,16)
