- IBORAT2C ;ALB/RJS - OUTPUT ROUTINE FOR BILLING RATES REPORT - 1/22/92
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- START ;
- S IBROUT="IBORAT2B",IBOUTPUT=0
- S IBSPEC="",IBOLDSPC=""
- F S IBSPEC=$O(^TMP($J,IBROUT,IBSPEC)) Q:IBSPEC=""!(IBDONE) D IBEFFDAT
- END ;
- K IBCANCEL,IBEFFDAT,IBDATA,IBOLDSPC,IBREVCD,IBREVCDE,IBREVFLG,IBROUT,IBSPEC,X,Y,IBAAA,C
- Q
- IBEFFDAT ;
- S IBEFFDAT=-1
- F S IBEFFDAT=$O(^TMP($J,IBROUT,IBSPEC,IBEFFDAT)) Q:IBEFFDAT=""!(IBDONE) D IBREVCDE
- Q
- IBREVCDE ;
- S IBREVCDE="",IBREVFLG=0
- F S IBREVCDE=$O(^TMP($J,IBROUT,IBSPEC,IBEFFDAT,IBREVCDE)) Q:IBREVCDE=""!(IBDONE) D IBPAYORS
- Q
- IBPAYORS ;
- S IBPAYORS=""
- F S IBPAYORS=$O(^TMP($J,IBROUT,IBSPEC,IBEFFDAT,IBREVCDE,IBPAYORS)) Q:IBPAYORS=""!(IBDONE) D OUTPUT:$$SELECT(IBPAYORS)
- Q
- OUTPUT ;
- I IBREVFLG=0 W ! S IBREVFLG=1
- I IBOUTPUT=0 D IBTITLE S (IBOUTPUT,IBZ)=1
- I IBOLDSPC'=IBSPEC&($Y+8>IOSL) S IBOLDSPC=IBSPEC D HEADING G LINE
- I IBOLDSPC'=IBSPEC S IBOLDSPC=IBSPEC D SUBHEAD
- LINE ;
- I IBDONE Q
- D:$Y+4>IOSL HEADING
- I IBDONE Q
- S IBDATA=^TMP($J,"IBORAT2B",IBSPEC,IBEFFDAT,IBREVCDE,IBPAYORS)
- S Y=IBEFFDAT D DD^%DT
- S IBREVCD=$G(^DGCR(399.2,IBREVCDE,0)),IBREVCD=$P(IBREVCD,U,1)
- ;AMOUNT=PIECE 2, ACTIVE=PIECE 4, PAYORS CODE=PIECE 3,NON STANDARD=$P 5
- W !,?2,Y,?19,"$",$P(IBDATA,U,2),?27,IBREVCD
- S Y=$P(IBDATA,U,4),C=$P(^DD(399.5,.05,0),U,2) D Y^DIQ W ?37,$S(Y="YES, ACTIVE":"YES",1:"NO")
- S Y=IBPAYORS,C=$P(^DD(399.5,.06,0),U,2) D Y^DIQ W ?45,$E(Y,1,20)
- S Y=$P(IBDATA,U,5),C=$P(^DD(399.5,.07,0),U,2) D Y^DIQ W ?70,$S(Y="YES":"YES",1:"NO")
- Q
- SUBHEAD ;
- W !!,IBSPEC,!,?2,"Effective Date",?19,"Amount",?27,"Rev Code",?37,"Active",?45,"Payors to use",?66,"Non-Standard"
- Q
- HEADING ;
- F IBAAA=$Y:1:(IOSL-3) W !
- I ($E(IOST,1,2)="C-")
- I S DIR(0)="E" D ^DIR K DIR I Y=0!(Y="")!($D(DIRUT)) S IBDONE=1 Q
- D IBTITLE,SUBHEAD
- Q
- IBTITLE ;
- W @IOF,!,IBTODAY,?25,IBTITLE,?68," PAGE ",IBPAGE
- D DATES
- S X="",$P(X,"=",IOM)="" W X
- S IBPAGE=IBPAGE+1
- Q
- DATES ;
- I IBSDATE=IBEDATE W !,?25," Rates in effect on: ",IBSDATE,! Q
- W !,?25," Rates in effect from: ",IBSDATE
- W !,?25," to: ",IBEDATE,!
- Q
- SELECT(IBPAYORS) ;
- S IBCANCEL=$P(^TMP($J,IBROUT,IBSPEC,IBEFFDAT,IBREVCDE,IBPAYORS),U,1)
- I (IBSTDATE'>IBEFFDAT)&(IBENDATE'<IBEFFDAT) Q 1
- I (IBSTDATE'<IBEFFDAT)&(IBSTDATE'>IBCANCEL) Q 1
- Q 0
- IBORAT2C ;ALB/RJS - OUTPUT ROUTINE FOR BILLING RATES REPORT - 1/22/92
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- START ;
- +1 SET IBROUT="IBORAT2B"
- SET IBOUTPUT=0
- +2 SET IBSPEC=""
- SET IBOLDSPC=""
- +3 FOR
- SET IBSPEC=$ORDER(^TMP($JOB,IBROUT,IBSPEC))
- IF IBSPEC=""!(IBDONE)
- QUIT
- DO IBEFFDAT
- END ;
- +1 KILL IBCANCEL,IBEFFDAT,IBDATA,IBOLDSPC,IBREVCD,IBREVCDE,IBREVFLG,IBROUT,IBSPEC,X,Y,IBAAA,C
- +2 QUIT
- IBEFFDAT ;
- +1 SET IBEFFDAT=-1
- +2 FOR
- SET IBEFFDAT=$ORDER(^TMP($JOB,IBROUT,IBSPEC,IBEFFDAT))
- IF IBEFFDAT=""!(IBDONE)
- QUIT
- DO IBREVCDE
- +3 QUIT
- IBREVCDE ;
- +1 SET IBREVCDE=""
- SET IBREVFLG=0
- +2 FOR
- SET IBREVCDE=$ORDER(^TMP($JOB,IBROUT,IBSPEC,IBEFFDAT,IBREVCDE))
- IF IBREVCDE=""!(IBDONE)
- QUIT
- DO IBPAYORS
- +3 QUIT
- IBPAYORS ;
- +1 SET IBPAYORS=""
- +2 FOR
- SET IBPAYORS=$ORDER(^TMP($JOB,IBROUT,IBSPEC,IBEFFDAT,IBREVCDE,IBPAYORS))
- IF IBPAYORS=""!(IBDONE)
- QUIT
- IF $$SELECT(IBPAYORS)
- DO OUTPUT
- +3 QUIT
- OUTPUT ;
- +1 IF IBREVFLG=0
- WRITE !
- SET IBREVFLG=1
- +2 IF IBOUTPUT=0
- DO IBTITLE
- SET (IBOUTPUT,IBZ)=1
- +3 IF IBOLDSPC'=IBSPEC&($Y+8>IOSL)
- SET IBOLDSPC=IBSPEC
- DO HEADING
- GOTO LINE
- +4 IF IBOLDSPC'=IBSPEC
- SET IBOLDSPC=IBSPEC
- DO SUBHEAD
- LINE ;
- +1 IF IBDONE
- QUIT
- +2 IF $Y+4>IOSL
- DO HEADING
- +3 IF IBDONE
- QUIT
- +4 SET IBDATA=^TMP($JOB,"IBORAT2B",IBSPEC,IBEFFDAT,IBREVCDE,IBPAYORS)
- +5 SET Y=IBEFFDAT
- DO DD^%DT
- +6 SET IBREVCD=$GET(^DGCR(399.2,IBREVCDE,0))
- SET IBREVCD=$PIECE(IBREVCD,U,1)
- +7 ;AMOUNT=PIECE 2, ACTIVE=PIECE 4, PAYORS CODE=PIECE 3,NON STANDARD=$P 5
- +8 WRITE !,?2,Y,?19,"$",$PIECE(IBDATA,U,2),?27,IBREVCD
- +9 SET Y=$PIECE(IBDATA,U,4)
- SET C=$PIECE(^DD(399.5,.05,0),U,2)
- DO Y^DIQ
- WRITE ?37,$SELECT(Y="YES, ACTIVE":"YES",1:"NO")
- +10 SET Y=IBPAYORS
- SET C=$PIECE(^DD(399.5,.06,0),U,2)
- DO Y^DIQ
- WRITE ?45,$EXTRACT(Y,1,20)
- +11 SET Y=$PIECE(IBDATA,U,5)
- SET C=$PIECE(^DD(399.5,.07,0),U,2)
- DO Y^DIQ
- WRITE ?70,$SELECT(Y="YES":"YES",1:"NO")
- +12 QUIT
- SUBHEAD ;
- +1 WRITE !!,IBSPEC,!,?2,"Effective Date",?19,"Amount",?27,"Rev Code",?37,"Active",?45,"Payors to use",?66,"Non-Standard"
- +2 QUIT
- HEADING ;
- +1 FOR IBAAA=$Y:1:(IOSL-3)
- WRITE !
- +2 IF ($EXTRACT(IOST,1,2)="C-")
- +3 IF $TEST
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- IF Y=0!(Y="")!($DATA(DIRUT))
- SET IBDONE=1
- QUIT
- +4 DO IBTITLE
- DO SUBHEAD
- +5 QUIT
- IBTITLE ;
- +1 WRITE @IOF,!,IBTODAY,?25,IBTITLE,?68," PAGE ",IBPAGE
- +2 DO DATES
- +3 SET X=""
- SET $PIECE(X,"=",IOM)=""
- WRITE X
- +4 SET IBPAGE=IBPAGE+1
- +5 QUIT
- DATES ;
- +1 IF IBSDATE=IBEDATE
- WRITE !,?25," Rates in effect on: ",IBSDATE,!
- QUIT
- +2 WRITE !,?25," Rates in effect from: ",IBSDATE
- +3 WRITE !,?25," to: ",IBEDATE,!
- +4 QUIT
- SELECT(IBPAYORS) ;
- +1 SET IBCANCEL=$PIECE(^TMP($JOB,IBROUT,IBSPEC,IBEFFDAT,IBREVCDE,IBPAYORS),U,1)
- +2 IF (IBSTDATE'>IBEFFDAT)&(IBENDATE'<IBEFFDAT)
- QUIT 1
- +3 IF (IBSTDATE'<IBEFFDAT)&(IBSTDATE'>IBCANCEL)
- QUIT 1
- +4 QUIT 0
