- IBCRON ;ALB/ARH - RATES: REPORTS PROVIDER DISCOUNT ; 10-OCT-98
- ;;2.0;INTEGRATED BILLING;**106,148**;21-MAR-94
- ;
- EN ;get parameters then run the report
- D HOME^%ZIS N DIR,X,Y,IBRPT,IBSRT W !!
- S DIR("?")="Enter 'Y' for a list of all Providers in a discount group. Enter 'N' for a list of discount groups."
- S DIR(0)="YO",DIR("A")="Print report by Provider",DIR("B")="NO" D ^DIR K DIR I $D(DIRUT) G EXIT
- S IBRPT=Y
- ;
- I +IBRPT S DIR(0)="SO^1:Provider Type;2:Provider Name",DIR("A")="Sort Report By" D ^DIR K DIR I $D(DIRUT) G EXIT
- S IBSRT=+Y
- ;
- ;
- DEV ;get the device
- W !!,"Report requires 132 columns."
- S %ZIS="QM",%ZIS("A")="OUTPUT DEVICE: " D ^%ZIS G:POP EXIT
- I $D(IO("Q")) S ZTRTN="RPT^IBCRON",ZTSAVE("IB*")="",ZTDESC="IB Provider Discount List" D ^%ZTLOAD K IO("Q") G EXIT
- U IO
- ;
- RPT ;find, save, and print the data that satisfies the search parameters
- ;entry point for tasked jobs
- ;
- K ^TMP($J,"IBCRON")
- ;
- I 'IBRPT D SORT,PRINT
- I +IBRPT,+IBSRT D SORT2,PRINT2
- ;
- EXIT ;clean up and quit
- K ^TMP($J,"IBCRON") Q:$D(ZTQUEUED)
- D ^%ZISC
- Q
- ;
- SORT ;save the data in sorted order in a temporary file, sort by Special Group Name then Provider Type Name
- N IBPD0,IBPDFN,IBPDN,IBSGFN,IBSGN,IBPCFN,IBPCVA
- ;
- S IBPDFN=0 F S IBPDFN=$O(^IBE(363.34,IBPDFN)) Q:'IBPDFN D
- . S IBPD0=$G(^IBE(363.34,+IBPDFN,0)),IBPDN=$P(IBPD0,U,1)_" "
- . S IBSGFN=+$P(IBPD0,U,2),IBSGN=$P($G(^IBE(363.32,+IBSGFN,0)),U,1)_" "
- . S ^TMP($J,"IBCRON",IBSGN)=IBSGFN
- . S ^TMP($J,"IBCRON",IBSGN,IBPDN,IBPDFN)=""
- . ;
- . S IBPCFN=0 F S IBPCFN=$O(^IBE(363.34,IBPDFN,11,"B",IBPCFN)) Q:'IBPCFN D
- .. S IBPCVA=$$IEN2CODE^XUA4A72(IBPCFN),IBPCVA=IBPCVA_" "
- .. S ^TMP($J,"IBCRON",IBSGN,IBPDN,IBPDFN,IBPCVA,IBPCFN)=""
- Q
- ;
- PRINT ;print the report from the temp sort file to the appropriate device
- N IBPGN,IBLN,IBQUIT,IBSGN,IBSG0,IBPDN,IBPDFN,IBPD0,IBPCFN,IBPC0,IBL,IBT,IBI,X,Y,IBPCVA
- S IBPGN=0,IBQUIT=0 D HDR Q:IBQUIT
- ;
- S IBSGN="" F S IBSGN=$O(^TMP($J,"IBCRON",IBSGN)) Q:IBSGN="" D Q:$$LNCHK(7)
- . S IBSG0=^TMP($J,"IBCRON",IBSGN),IBSG0=$G(^IBE(363.32,+IBSG0,0))
- . ;
- . S IBL=$L("GROUP: "_$P(IBSG0,U,1)),IBT=(IOM-IBL)\2
- . W !!,?IBT,"GROUP: ",$P(IBSG0,U,1),!,?IBT S IBLN=IBLN+2
- . S IBI="",$P(IBI,"-",IBL+1)="" W IBI
- . ;
- . S IBPDN="" F S IBPDN=$O(^TMP($J,"IBCRON",IBSGN,IBPDN)) Q:IBPDN="" D Q:IBQUIT
- .. S IBPDFN=0 F S IBPDFN=$O(^TMP($J,"IBCRON",IBSGN,IBPDN,IBPDFN)) Q:'IBPDFN D Q:$$LNCHK(4)
- ... S IBPD0=$G(^IBE(363.34,+IBPDFN,0))
- ... ;
- ... W !!,$E($P(IBPD0,U,1),1,30),?35,$S($P(IBPD0,U,3)'="":$J(+$P(IBPD0,U,3),6)_"%",1:""),! S IBLN=IBLN+3
- ... ;
- ... S IBPCVA="" F S IBPCVA=$O(^TMP($J,"IBCRON",IBSGN,IBPDN,IBPDFN,IBPCVA)) Q:IBPCVA="" D Q:$$LNCHK(2)
- .... S IBPCFN=0 F S IBPCFN=$O(^TMP($J,"IBCRON",IBSGN,IBPDN,IBPDFN,IBPCVA,IBPCFN)) Q:'IBPCFN D
- ..... S IBPC0=$$CODE2TXT^XUA4A72(IBPCFN)
- ..... ;
- ..... W !,?5,IBPCVA,?16,$E($P(IBPC0,U,1),1,38),?56,$E($P(IBPC0,U,2),1,37),?95,$E($P(IBPC0,U,3),1,36) S IBLN=IBLN+1
- ;
- I 'IBQUIT D PAUSE
- Q
- LNCHK(LNS) ; check if new page is needed
- I 'IBQUIT,IBLN>(IOSL-LNS) D PAUSE I 'IBQUIT D HDR
- Q IBQUIT
- ;
- HDR ;print the report header
- N IBNOW,IBI
- S IBQUIT=$$STOP Q:IBQUIT S IBPGN=IBPGN+1,IBLN=7
- S IBNOW=$$FMTE^XLFDT($$NOW^XLFDT),IBNOW=$P(IBNOW,"@",1)_" "_$P($P(IBNOW,"@",2),":",1,2)
- I IBPGN>1!($E(IOST,1,2)["C-") W @IOF
- ;
- W !,"BILLING PROVIDER DISCOUNT LIST",?(IOM-30),IBNOW,?(IOM-8),"PAGE ",IBPGN,!
- W !,"PROVIDER TYPE",?36,"PERCENT",!,?5,"VA Code",?16,"Occupation",?56,"Specialty",?95,"Subspecialty",!
- S IBI="",$P(IBI,"-",IOM+1)="" W IBI
- Q
- ;
- PAUSE ;pause at end of screen if beeing displayed on a terminal
- Q:$E(IOST,1,2)'["C-" N DIR,DUOUT,DTOUT,DIRUT W !
- S DIR(0)="E" D ^DIR K DIR
- I $D(DUOUT)!($D(DIRUT)) S IBQUIT=1
- Q
- ;
- STOP() ;determine if user has requested the queued report to stop
- I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPGN) W !,"***TASK STOPPED BY USER***"
- Q +$G(ZTSTOP)
- ;
- ;
- ;
- SORT2 ;save the data in sorted order in a temporary file, sort by Special Group Name then Provider Type Name
- N IBPRV,IBNM,IBPC,IBPDFN,IBPD0,IBPDNM,IBPDSG,IBCNT S IBCNT=0
- ;
- S IBPRV=0 F S IBPRV=$O(^VA(200,IBPRV)) Q:'IBPRV D
- . S IBNM=$P($G(^VA(200,IBPRV,0)),U,1)
- . S IBPC=$$GET^XUA4A72(IBPRV)
- . ;
- . S IBPDFN=0 F S IBPDFN=$O(^IBE(363.34,"D",+IBPC,IBPDFN)) Q:'IBPDFN D
- .. S IBPD0=$G(^IBE(363.34,IBPDFN,0)),IBPDNM=$P(IBPD0,U,1),IBPDSG=$P(IBPD0,U,2)
- .. S IBCNT=IBCNT+1
- .. ;
- .. S ^TMP($J,"IBCRON",IBCNT)=IBNM_U_IBPDFN_U_IBPC
- .. ;
- .. I IBSRT=1 S ^TMP($J,"IBCRON","B",IBPDSG,IBPDNM,IBNM)=IBCNT Q
- .. I IBSRT=2 S ^TMP($J,"IBCRON","B",IBPDSG,IBNM,IBPDNM)=IBCNT Q
- Q
- ;
- PRINT2 ;print the report from the temp sort file to the appropriate device
- N IBPGN,IBLN,IBQUIT,IBPDSG,IBS1,IBS2,IBTMP,IBLNI,IBPDP,X,Y
- S IBPGN=0,IBQUIT=0
- ;
- S IBPDSG=0 F S IBPDSG=$O(^TMP($J,"IBCRON","B",IBPDSG)) Q:'IBPDSG D HDR2 D Q:IBQUIT D PAUSE
- . S IBS1="" F S IBS1=$O(^TMP($J,"IBCRON","B",IBPDSG,IBS1)) Q:IBS1="" D Q:$$LNCHK(2)
- .. S IBS2="" F S IBS2=$O(^TMP($J,"IBCRON","B",IBPDSG,IBS1,IBS2)) Q:IBS2="" D Q:$$LNCHK(2)
- ... S IBTMP=$G(^TMP($J,"IBCRON","B",IBPDSG,IBS1,IBS2)) Q:'IBTMP
- ... S IBLNI=$G(^TMP($J,"IBCRON",IBTMP)) Q:IBLNI=""
- ... S IBPDP=$P($G(^IBE(363.34,$P(IBLNI,U,2),0)),U,3),IBPDP=$S(IBPDP'="":IBPDP_"%",1:"")
- ... ;
- ... W !,$E(IBS1,1,21),?25,$E(IBS2,1,21),?47,$J(IBPDP,4) S IBLN=IBLN+1
- ... W ?53,$P(IBLNI,U,9),?62,$E($P(IBLNI,U,4),1,22),?85,$E($P(IBLNI,U,5),1,22),?110,$E($P(IBLNI,U,6),1,22)
- ;
- Q
- ;
- HDR2 ;print the report header
- N IBNOW,IBI
- S IBQUIT=$$STOP Q:IBQUIT S IBPGN=IBPGN+1,IBLN=7
- S IBNOW=$$FMTE^XLFDT($$NOW^XLFDT),IBNOW=$P(IBNOW,"@",1)_" "_$P($P(IBNOW,"@",2),":",1,2)
- I IBPGN>1!($E(IOST,1,2)["C-") W @IOF
- ;
- W !,"BILLING PROVIDER DISCOUNT LIST FOR PROVIDERS",?(IOM-30),IBNOW,?(IOM-8),"PAGE ",IBPGN
- W !,"SPECIAL GROUP: ",$P($G(^IBE(363.32,+$G(IBPDSG),0)),U,1),?53,"PERSON CLASS:"
- I IBSRT=1 W !,"PROVIDER TYPE",?25,"PROVIDER"
- I IBSRT=2 W !,"PROVIDER",?25,"PROVIDER TYPE"
- W ?49,"%",?53,"VA Code",?66,"Occupation",?88,"Specialty",?110,"Subspecialty",!
- S IBI="",$P(IBI,"-",IOM+1)="" W IBI
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRON 6120 printed Mar 13, 2025@21:24:52 Page 2
- IBCRON ;ALB/ARH - RATES: REPORTS PROVIDER DISCOUNT ; 10-OCT-98
- +1 ;;2.0;INTEGRATED BILLING;**106,148**;21-MAR-94
- +2 ;
- EN ;get parameters then run the report
- +1 DO HOME^%ZIS
- NEW DIR,X,Y,IBRPT,IBSRT
- WRITE !!
- +2 SET DIR("?")="Enter 'Y' for a list of all Providers in a discount group. Enter 'N' for a list of discount groups."
- +3 SET DIR(0)="YO"
- SET DIR("A")="Print report by Provider"
- SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- GOTO EXIT
- +4 SET IBRPT=Y
- +5 ;
- +6 IF +IBRPT
- SET DIR(0)="SO^1:Provider Type;2:Provider Name"
- SET DIR("A")="Sort Report By"
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- GOTO EXIT
- +7 SET IBSRT=+Y
- +8 ;
- +9 ;
- DEV ;get the device
- +1 WRITE !!,"Report requires 132 columns."
- +2 SET %ZIS="QM"
- SET %ZIS("A")="OUTPUT DEVICE: "
- DO ^%ZIS
- if POP
- GOTO EXIT
- +3 IF $DATA(IO("Q"))
- SET ZTRTN="RPT^IBCRON"
- SET ZTSAVE("IB*")=""
- SET ZTDESC="IB Provider Discount List"
- DO ^%ZTLOAD
- KILL IO("Q")
- GOTO EXIT
- +4 USE IO
- +5 ;
- RPT ;find, save, and print the data that satisfies the search parameters
- +1 ;entry point for tasked jobs
- +2 ;
- +3 KILL ^TMP($JOB,"IBCRON")
- +4 ;
- +5 IF 'IBRPT
- DO SORT
- DO PRINT
- +6 IF +IBRPT
- IF +IBSRT
- DO SORT2
- DO PRINT2
- +7 ;
- EXIT ;clean up and quit
- +1 KILL ^TMP($JOB,"IBCRON")
- if $DATA(ZTQUEUED)
- QUIT
- +2 DO ^%ZISC
- +3 QUIT
- +4 ;
- SORT ;save the data in sorted order in a temporary file, sort by Special Group Name then Provider Type Name
- +1 NEW IBPD0,IBPDFN,IBPDN,IBSGFN,IBSGN,IBPCFN,IBPCVA
- +2 ;
- +3 SET IBPDFN=0
- FOR
- SET IBPDFN=$ORDER(^IBE(363.34,IBPDFN))
- if 'IBPDFN
- QUIT
- Begin DoDot:1
- +4 SET IBPD0=$GET(^IBE(363.34,+IBPDFN,0))
- SET IBPDN=$PIECE(IBPD0,U,1)_" "
- +5 SET IBSGFN=+$PIECE(IBPD0,U,2)
- SET IBSGN=$PIECE($GET(^IBE(363.32,+IBSGFN,0)),U,1)_" "
- +6 SET ^TMP($JOB,"IBCRON",IBSGN)=IBSGFN
- +7 SET ^TMP($JOB,"IBCRON",IBSGN,IBPDN,IBPDFN)=""
- +8 ;
- +9 SET IBPCFN=0
- FOR
- SET IBPCFN=$ORDER(^IBE(363.34,IBPDFN,11,"B",IBPCFN))
- if 'IBPCFN
- QUIT
- Begin DoDot:2
- +10 SET IBPCVA=$$IEN2CODE^XUA4A72(IBPCFN)
- SET IBPCVA=IBPCVA_" "
- +11 SET ^TMP($JOB,"IBCRON",IBSGN,IBPDN,IBPDFN,IBPCVA,IBPCFN)=""
- End DoDot:2
- End DoDot:1
- +12 QUIT
- +13 ;
- PRINT ;print the report from the temp sort file to the appropriate device
- +1 NEW IBPGN,IBLN,IBQUIT,IBSGN,IBSG0,IBPDN,IBPDFN,IBPD0,IBPCFN,IBPC0,IBL,IBT,IBI,X,Y,IBPCVA
- +2 SET IBPGN=0
- SET IBQUIT=0
- DO HDR
- if IBQUIT
- QUIT
- +3 ;
- +4 SET IBSGN=""
- FOR
- SET IBSGN=$ORDER(^TMP($JOB,"IBCRON",IBSGN))
- if IBSGN=""
- QUIT
- Begin DoDot:1
- +5 SET IBSG0=^TMP($JOB,"IBCRON",IBSGN)
- SET IBSG0=$GET(^IBE(363.32,+IBSG0,0))
- +6 ;
- +7 SET IBL=$LENGTH("GROUP: "_$PIECE(IBSG0,U,1))
- SET IBT=(IOM-IBL)\2
- +8 WRITE !!,?IBT,"GROUP: ",$PIECE(IBSG0,U,1),!,?IBT
- SET IBLN=IBLN+2
- +9 SET IBI=""
- SET $PIECE(IBI,"-",IBL+1)=""
- WRITE IBI
- +10 ;
- +11 SET IBPDN=""
- FOR
- SET IBPDN=$ORDER(^TMP($JOB,"IBCRON",IBSGN,IBPDN))
- if IBPDN=""
- QUIT
- Begin DoDot:2
- +12 SET IBPDFN=0
- FOR
- SET IBPDFN=$ORDER(^TMP($JOB,"IBCRON",IBSGN,IBPDN,IBPDFN))
- if 'IBPDFN
- QUIT
- Begin DoDot:3
- +13 SET IBPD0=$GET(^IBE(363.34,+IBPDFN,0))
- +14 ;
- +15 WRITE !!,$EXTRACT($PIECE(IBPD0,U,1),1,30),?35,$SELECT($PIECE(IBPD0,U,3)'="":$JUSTIFY(+$PIECE(IBPD0,U,3),6)_"%",1:""),!
- SET IBLN=IBLN+3
- +16 ;
- +17 SET IBPCVA=""
- FOR
- SET IBPCVA=$ORDER(^TMP($JOB,"IBCRON",IBSGN,IBPDN,IBPDFN,IBPCVA))
- if IBPCVA=""
- QUIT
- Begin DoDot:4
- +18 SET IBPCFN=0
- FOR
- SET IBPCFN=$ORDER(^TMP($JOB,"IBCRON",IBSGN,IBPDN,IBPDFN,IBPCVA,IBPCFN))
- if 'IBPCFN
- QUIT
- Begin DoDot:5
- +19 SET IBPC0=$$CODE2TXT^XUA4A72(IBPCFN)
- +20 ;
- +21 WRITE !,?5,IBPCVA,?16,$EXTRACT($PIECE(IBPC0,U,1),1,38),?56,$EXTRACT($PIECE(IBPC0,U,2),1,37),?95,$EXTRACT($PIECE(IBPC0,U,3),1,36)
- SET IBLN=IBLN+1
- End DoDot:5
- End DoDot:4
- if $$LNCHK(2)
- QUIT
- End DoDot:3
- if $$LNCHK(4)
- QUIT
- End DoDot:2
- if IBQUIT
- QUIT
- End DoDot:1
- if $$LNCHK(7)
- QUIT
- +22 ;
- +23 IF 'IBQUIT
- DO PAUSE
- +24 QUIT
- LNCHK(LNS) ; check if new page is needed
- +1 IF 'IBQUIT
- IF IBLN>(IOSL-LNS)
- DO PAUSE
- IF 'IBQUIT
- DO HDR
- +2 QUIT IBQUIT
- +3 ;
- HDR ;print the report header
- +1 NEW IBNOW,IBI
- +2 SET IBQUIT=$$STOP
- if IBQUIT
- QUIT
- SET IBPGN=IBPGN+1
- SET IBLN=7
- +3 SET IBNOW=$$FMTE^XLFDT($$NOW^XLFDT)
- SET IBNOW=$PIECE(IBNOW,"@",1)_" "_$PIECE($PIECE(IBNOW,"@",2),":",1,2)
- +4 IF IBPGN>1!($EXTRACT(IOST,1,2)["C-")
- WRITE @IOF
- +5 ;
- +6 WRITE !,"BILLING PROVIDER DISCOUNT LIST",?(IOM-30),IBNOW,?(IOM-8),"PAGE ",IBPGN,!
- +7 WRITE !,"PROVIDER TYPE",?36,"PERCENT",!,?5,"VA Code",?16,"Occupation",?56,"Specialty",?95,"Subspecialty",!
- +8 SET IBI=""
- SET $PIECE(IBI,"-",IOM+1)=""
- WRITE IBI
- +9 QUIT
- +10 ;
- PAUSE ;pause at end of screen if beeing displayed on a terminal
- +1 if $EXTRACT(IOST,1,2)'["C-"
- QUIT
- NEW DIR,DUOUT,DTOUT,DIRUT
- WRITE !
- +2 SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- +3 IF $DATA(DUOUT)!($DATA(DIRUT))
- SET IBQUIT=1
- +4 QUIT
- +5 ;
- STOP() ;determine if user has requested the queued report to stop
- +1 IF $DATA(ZTQUEUED)
- IF $$S^%ZTLOAD
- SET ZTSTOP=1
- KILL ZTREQ
- IF +$GET(IBPGN)
- WRITE !,"***TASK STOPPED BY USER***"
- +2 QUIT +$GET(ZTSTOP)
- +3 ;
- +4 ;
- +5 ;
- SORT2 ;save the data in sorted order in a temporary file, sort by Special Group Name then Provider Type Name
- +1 NEW IBPRV,IBNM,IBPC,IBPDFN,IBPD0,IBPDNM,IBPDSG,IBCNT
- SET IBCNT=0
- +2 ;
- +3 SET IBPRV=0
- FOR
- SET IBPRV=$ORDER(^VA(200,IBPRV))
- if 'IBPRV
- QUIT
- Begin DoDot:1
- +4 SET IBNM=$PIECE($GET(^VA(200,IBPRV,0)),U,1)
- +5 SET IBPC=$$GET^XUA4A72(IBPRV)
- +6 ;
- +7 SET IBPDFN=0
- FOR
- SET IBPDFN=$ORDER(^IBE(363.34,"D",+IBPC,IBPDFN))
- if 'IBPDFN
- QUIT
- Begin DoDot:2
- +8 SET IBPD0=$GET(^IBE(363.34,IBPDFN,0))
- SET IBPDNM=$PIECE(IBPD0,U,1)
- SET IBPDSG=$PIECE(IBPD0,U,2)
- +9 SET IBCNT=IBCNT+1
- +10 ;
- +11 SET ^TMP($JOB,"IBCRON",IBCNT)=IBNM_U_IBPDFN_U_IBPC
- +12 ;
- +13 IF IBSRT=1
- SET ^TMP($JOB,"IBCRON","B",IBPDSG,IBPDNM,IBNM)=IBCNT
- QUIT
- +14 IF IBSRT=2
- SET ^TMP($JOB,"IBCRON","B",IBPDSG,IBNM,IBPDNM)=IBCNT
- QUIT
- End DoDot:2
- End DoDot:1
- +15 QUIT
- +16 ;
- PRINT2 ;print the report from the temp sort file to the appropriate device
- +1 NEW IBPGN,IBLN,IBQUIT,IBPDSG,IBS1,IBS2,IBTMP,IBLNI,IBPDP,X,Y
- +2 SET IBPGN=0
- SET IBQUIT=0
- +3 ;
- +4 SET IBPDSG=0
- FOR
- SET IBPDSG=$ORDER(^TMP($JOB,"IBCRON","B",IBPDSG))
- if 'IBPDSG
- QUIT
- DO HDR2
- Begin DoDot:1
- +5 SET IBS1=""
- FOR
- SET IBS1=$ORDER(^TMP($JOB,"IBCRON","B",IBPDSG,IBS1))
- if IBS1=""
- QUIT
- Begin DoDot:2
- +6 SET IBS2=""
- FOR
- SET IBS2=$ORDER(^TMP($JOB,"IBCRON","B",IBPDSG,IBS1,IBS2))
- if IBS2=""
- QUIT
- Begin DoDot:3
- +7 SET IBTMP=$GET(^TMP($JOB,"IBCRON","B",IBPDSG,IBS1,IBS2))
- if 'IBTMP
- QUIT
- +8 SET IBLNI=$GET(^TMP($JOB,"IBCRON",IBTMP))
- if IBLNI=""
- QUIT
- +9 SET IBPDP=$PIECE($GET(^IBE(363.34,$PIECE(IBLNI,U,2),0)),U,3)
- SET IBPDP=$SELECT(IBPDP'="":IBPDP_"%",1:"")
- +10 ;
- +11 WRITE !,$EXTRACT(IBS1,1,21),?25,$EXTRACT(IBS2,1,21),?47,$JUSTIFY(IBPDP,4)
- SET IBLN=IBLN+1
- +12 WRITE ?53,$PIECE(IBLNI,U,9),?62,$EXTRACT($PIECE(IBLNI,U,4),1,22),?85,$EXTRACT($PIECE(IBLNI,U,5),1,22),?110,$EXTRACT($PIECE(IBLNI,U,6),1,22)
- End DoDot:3
- if $$LNCHK(2)
- QUIT
- End DoDot:2
- if $$LNCHK(2)
- QUIT
- End DoDot:1
- if IBQUIT
- QUIT
- DO PAUSE
- +13 ;
- +14 QUIT
- +15 ;
- HDR2 ;print the report header
- +1 NEW IBNOW,IBI
- +2 SET IBQUIT=$$STOP
- if IBQUIT
- QUIT
- SET IBPGN=IBPGN+1
- SET IBLN=7
- +3 SET IBNOW=$$FMTE^XLFDT($$NOW^XLFDT)
- SET IBNOW=$PIECE(IBNOW,"@",1)_" "_$PIECE($PIECE(IBNOW,"@",2),":",1,2)
- +4 IF IBPGN>1!($EXTRACT(IOST,1,2)["C-")
- WRITE @IOF
- +5 ;
- +6 WRITE !,"BILLING PROVIDER DISCOUNT LIST FOR PROVIDERS",?(IOM-30),IBNOW,?(IOM-8),"PAGE ",IBPGN
- +7 WRITE !,"SPECIAL GROUP: ",$PIECE($GET(^IBE(363.32,+$GET(IBPDSG),0)),U,1),?53,"PERSON CLASS:"
- +8 IF IBSRT=1
- WRITE !,"PROVIDER TYPE",?25,"PROVIDER"
- +9 IF IBSRT=2
- WRITE !,"PROVIDER",?25,"PROVIDER TYPE"
- +10 WRITE ?49,"%",?53,"VA Code",?66,"Occupation",?88,"Specialty",?110,"Subspecialty",!
- +11 SET IBI=""
- SET $PIECE(IBI,"-",IOM+1)=""
- WRITE IBI
- +12 QUIT
