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 Sep 02, 2024@19:05:06 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
