IBATOP ;ALB/CPM-TRANSFER PRICING PATIENT LISTING ;21-MAR-99
;;2.0;INTEGRATED BILLING;**115,153,183,249**;21-MAR-94
;
EN ; Option entry point.
;
W !!,"This report creates a listing of all Transfer Pricing patients for"
W !,"specific networks or facilities. Please enter all applicable networks"
W !,"and facilities, specifying networks by VISN (i.e., 'VISN 1').",!
;
; - allow entry of network/facilities; quit if none entered
Q:$$FAC^IBATUTL
;
; - set flag to determine if all facilities were entered
S IBALL='$D(IBFAC)
;
W !!,"This report requires only an 80 column printer.",!
;
; - select a device
S %ZIS="QM" D ^%ZIS I POP G ENQ
I $D(IO("Q")) D G ENQ
.S ZTRTN="DQ^IBATOP",ZTDESC="IB - TRANSFER PRICING PATIENT LISTING"
.S ZTSAVE("IBALL")="" I $D(IBFAC) S ZTSAVE("IBFAC(")=""
.D ^%ZTLOAD
.W !!,$S($D(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.")
.K ZTSK,IO("Q") D HOME^%ZIS
;
U IO
;
DQ ; Tasked entry point.
;
K ^TMP("IBATOP",$J),IBARR,IBFACN,^TMP($J,"SDAMA301"),^TMP("IBDFN",$J)
N IBARRAY,IBCOUNT,IBNDT
;
; - process the entire file if all patients were selected
I IBALL D G PRINT
.S DFN=0 F S DFN=$O(^IBAT(351.6,DFN)) Q:'DFN S IBD=$G(^(DFN,0)) D
..;
..; - get the enrolled facility and find the associated network
..S IBSTN=+$$PPF^IBATUTL(DFN)
..;S IBSTN=+$P(IBD,"^",3)
..I '$D(IBARR(IBSTN)) D
...N X,Y
...S X=$$VISN^IBATUTL(IBSTN),Y=$$INST^IBATUTL(IBSTN)
...S:$P(Y,"^",2)="" $P(Y,"^",2)="<No Sta. #>"
...S IBARR(IBSTN)=+$P($P(X,"^",2)," ",2)_"^"_Y
...S IBFACN(IBSTN)=Y
..;
..; - set patient information
..D SET(+IBARR(IBSTN),IBSTN,DFN)
;
; - process patients from selected networks/facilities
S IBX="" F S IBX=$O(IBFAC(IBX)) Q:IBX="" D
.S IBSTN="" F S IBSTN=$O(IBFAC(IBX,"C",IBSTN)) Q:IBSTN="" D
..;
..; - get facility/network information
..S IBNET=+$P($P($$VISN^IBATUTL(IBSTN),"^",2)," ",2)
..S IBY=$$INST^IBATUTL(IBSTN)
..S:$P(IBY,"^",2)="" $P(IBY,"^",2)="<No Sta. #>"
..S IBFACN(IBSTN)=IBY
..;
..; - find all patients from the specific facility
..S DFN=0 F S DFN=$O(^IBAT(351.6,"AD",IBSTN,DFN)) Q:'DFN D
...D SET(IBNET,IBSTN,DFN)
;
PRINT ;
; now call scheduling to look up future appts
S IBARRAY(1)=$$NOW^XLFDT_";9999999"
S IBARRAY(3)="R;I;NT"
S IBARRAY(4)="^TMP(""IBDFN"",$J,"
S IBARRAY("SORT")="P"
S IBARRAY("FLDS")=1
S IBCOUNT=$$SDAPI^SDAMA301(.IBARRAY)
;
; Print the report.
;
S (IBPAG,IBQ)=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%)
;
I '$D(^TMP("IBATOP",$J)) D HDR(0) W !!!,"There are no Transfer Pricing patients for the selected networks/facilities." G ENQ
;
S IBNET="" F S IBNET=$O(^TMP("IBATOP",$J,IBNET)) Q:IBNET=""!(IBQ) D
.D PAUSE:IBPAG,HDR(IBNET)
.S IBSTN="" F S IBSTN=$O(^TMP("IBATOP",$J,IBNET,IBSTN)) Q:IBSTN=""!(IBQ) D
..;
..I $Y>(IOSL-4) D PAUSE Q:IBQ D HDR(IBNET)
..D DISFAC(IBSTN)
..;
..S IBNAM="" F S IBNAM=$O(^TMP("IBATOP",$J,IBNET,IBSTN,IBNAM)) Q:IBNAM=""!(IBQ) S IBXX=$G(^(IBNAM)) D
...;
...I $Y>(IOSL-2) D PAUSE Q:IBQ D HDR(IBNET),DISFAC(IBSTN)
...;
...W !,$E($P(IBNAM,"@@"),1,20)," (",$P(IBXX,"^"),")"
...W ?28,$E($P(IBXX,"^",2),1,19),?49,$P(IBXX,"^",3),?55,$P(IBXX,"^",4)
...W ?61,$S($P(IBXX,"^",5):$$DAT1^IBOUTL($P(IBXX,"^",5)),1:"")
...S IBNDT=$O(^TMP($J,"SDAMA301",$P(IBNAM,"@@",2),0))
...I IBNDT S $P(IBXX,"^",6)=$S('$P(IBXX,"^",6):IBNDT,IBNDT<$P(IBXX,"^",6):IBNDT,1:$P(IBXX,"^",6))
...W ?71,$S($P(IBXX,"^",6):$$DAT1^IBOUTL($P(IBXX,"^",6)),1:"")
;
I 'IBQ D PAUSE
;
ENQ K ^TMP("IBATOP",$J)
I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
;
D ^%ZISC
ENQ1 K IBPAG,IBD,IBQ,IBRUN,IBNET,IBSTN,IBNAM,IBXX,IBY
K IBFAC,IBFACN,IBARR,IBALL,IBX,DFN,POP,X,Y,SDCNT
Q
;
;
SET(IBNET,IBSTA,DFN) ; Create the temporary sort file.
; Input: IBNET -- The network/VISN number
; IBSTA -- The Station number
; DFN -- Pointer to the patient in file #2
;
N IBDFN,IBINS,IBMT,IBTXMT,VAEL,VAERR
;
S IBDFN=$$PT^IBEFUNC(DFN)
S IBINS=$$INSURED^IBCNS1(DFN),IBMT=$P($$LST^DGMTU(DFN),"^",4)
S IBMT=$S(IBMT="C":"YES",IBMT="G":"GMT",IBMT="P":"PEN",IBMT="R":"REQ",1:"NO")
S IBTXMT=$$TXMT(DFN)
D ELIG^VADPT
;
; - set all patients to be included in array for next appt.
I $$GETICN^MPIF001(DFN)>0 S ^TMP("IBDFN",$J,DFN)=""
;
; - set all patient data into the temporary file
S ^TMP("IBATOP",$J,IBNET,IBSTA,$P(IBDFN,"^")_"@@"_DFN)=$P(IBDFN,"^",3)_"^"_$P(VAEL(1),"^",2)_"^"_IBMT_"^"_$S(IBINS:"YES",1:"NO")_"^"_IBTXMT
Q
;
TXMT(DFN) ; Find the patient's last treatment date and next sched date
; Input: DFN -- Pointer to the patient in file #2
; Output: 1^2, where
; 1 => last treatment date, or null
; 2 => next scheduled treatment date, or null
; (not including scheduling)
;
N IBDT,IBLT,IBNEXT,IBQ,X,X1,X2
S (IBLT,IBNEXT)=""
;
; - if current inpatient, set last treatment date to today
I $G(^DPT(DFN,.105)) S IBLT=DT G TXMTN
;
; - get the last discharge date
S IBLT=+$O(^DGPM("ATID3",DFN,"")) S:IBLT IBLT=9999999.9999999-IBLT\1
S:IBLT>DT IBLT=DT
;
; - get the last registration date and compare to last treatment date
S X=+$O(^DPT(DFN,"DIS",0)) I X S X=9999999-X\1 S:X>IBLT IBLT=X
;
; - get the last appointment or stop after last treatment date (if any)
K ^TMP("DIERR",$J)
I '$G(IBQ) D
.D OPEN^SDQ(.IBQ) Q:'$G(IBQ)
.D INDEX^SDQ(.IBQ,"PATIENT/DATE","SET")
.D SCANCB^SDQ(.IBQ,"I $S($P(SDOE0,U,8)=2:1,$P(SDOE0,U,8)=1:$$APPT^IBATOP(SDOE0),1:0) S IBLT=SDOE0\1,SDSTOP=1","SET")
;
D PAT^SDQ(.IBQ,DFN,"SET")
D DATE^SDQ(.IBQ,IBLT+.000001,9999999,"SET")
D ACTIVE^SDQ(.IBQ,"TRUE","SET")
D SCAN^SDQ(.IBQ,"BACKWARD")
D CLOSE^SDQ(.IBQ)
K ^TMP("DIERR",$J)
;
TXMTN ; - find next scheduled treatment date
S IBNEXT=""
S X=0 F S X=$O(^DGS(41.1,"B",DFN,X)) Q:'X D ; sched adm
.S X1=$G(^DGS(41.1,X,0))
.S X2=$P(X1,"^",2)\1
.Q:X2<DT ; must be old scheduled adm
.Q:$P(X1,"^",13) ; sched adm is cancelled
.Q:$P(X1,"^",17) ; patient already admitted
.I X2>IBNEXT S IBNEXT=X2
;
Q IBLT_"^"_IBNEXT
;
APPT(SDOE0) ; Determine if appt associated with encounter is valid
Q $S($P(SDOE0,U,12)=2:1,$P(SDOE0,U,12)=14:1,1:0)
;
;
PAUSE ; Page break
Q:$E(IOST,1,2)'="C-"
N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
F IBX=$Y:1:(IOSL-3) W !
S DIR(0)="E" D ^DIR I $D(DIRUT)!($D(DUOUT)) S IBQ=1
Q
;
HDR(IBNET) ; Write the detail report header.
I $E(IOST,1,2)="C-"!(IBPAG) W @IOF,*13
S IBPAG=IBPAG+1
W !,"Transfer Pricing Patient Listing",?38,"Run Date: ",IBRUN,?72,"Page: ",IBPAG
I $G(IBNET) W !,"Network: VISN ",IBNET
W !?50,"MT",?55,"Act",?63,"Last",?71,"Nxt Sched"
W !,"Patient Name/ID",?28,"Primary Eligibility",?49,"Stat"
W ?55,"Ins",?63,"Seen",?71,"Visit/Adm"
W !,$$DASH(IOM)
Q
;
DISFAC(X) ; Display the station number and name.
; Input: X -- The Station Number
; Variable input: IBFACN array
;
W !!?4,"Home Facility: ",$P(IBFACN(X),"^",2)," ",$P(IBFACN(X),"^"),!
Q
;
DASH(X) ; Return a dashed line.
Q $TR($J("",X)," ","=")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBATOP 7163 printed Jan 29, 2026@15:06:51 Page 2
IBATOP ;ALB/CPM-TRANSFER PRICING PATIENT LISTING ;21-MAR-99
+1 ;;2.0;INTEGRATED BILLING;**115,153,183,249**;21-MAR-94
+2 ;
EN ; Option entry point.
+1 ;
+2 WRITE !!,"This report creates a listing of all Transfer Pricing patients for"
+3 WRITE !,"specific networks or facilities. Please enter all applicable networks"
+4 WRITE !,"and facilities, specifying networks by VISN (i.e., 'VISN 1').",!
+5 ;
+6 ; - allow entry of network/facilities; quit if none entered
+7 if $$FAC^IBATUTL
QUIT
+8 ;
+9 ; - set flag to determine if all facilities were entered
+10 SET IBALL='$DATA(IBFAC)
+11 ;
+12 WRITE !!,"This report requires only an 80 column printer.",!
+13 ;
+14 ; - select a device
+15 SET %ZIS="QM"
DO ^%ZIS
IF POP
GOTO ENQ
+16 IF $DATA(IO("Q"))
Begin DoDot:1
+17 SET ZTRTN="DQ^IBATOP"
SET ZTDESC="IB - TRANSFER PRICING PATIENT LISTING"
+18 SET ZTSAVE("IBALL")=""
IF $DATA(IBFAC)
SET ZTSAVE("IBFAC(")=""
+19 DO ^%ZTLOAD
+20 WRITE !!,$SELECT($DATA(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job.")
+21 KILL ZTSK,IO("Q")
DO HOME^%ZIS
End DoDot:1
GOTO ENQ
+22 ;
+23 USE IO
+24 ;
DQ ; Tasked entry point.
+1 ;
+2 KILL ^TMP("IBATOP",$JOB),IBARR,IBFACN,^TMP($JOB,"SDAMA301"),^TMP("IBDFN",$JOB)
+3 NEW IBARRAY,IBCOUNT,IBNDT
+4 ;
+5 ; - process the entire file if all patients were selected
+6 IF IBALL
Begin DoDot:1
+7 SET DFN=0
FOR
SET DFN=$ORDER(^IBAT(351.6,DFN))
if 'DFN
QUIT
SET IBD=$GET(^(DFN,0))
Begin DoDot:2
+8 ;
+9 ; - get the enrolled facility and find the associated network
+10 SET IBSTN=+$$PPF^IBATUTL(DFN)
+11 ;S IBSTN=+$P(IBD,"^",3)
+12 IF '$DATA(IBARR(IBSTN))
Begin DoDot:3
+13 NEW X,Y
+14 SET X=$$VISN^IBATUTL(IBSTN)
SET Y=$$INST^IBATUTL(IBSTN)
+15 if $PIECE(Y,"^",2)=""
SET $PIECE(Y,"^",2)="<No Sta. #>"
+16 SET IBARR(IBSTN)=+$PIECE($PIECE(X,"^",2)," ",2)_"^"_Y
+17 SET IBFACN(IBSTN)=Y
End DoDot:3
+18 ;
+19 ; - set patient information
+20 DO SET(+IBARR(IBSTN),IBSTN,DFN)
End DoDot:2
End DoDot:1
GOTO PRINT
+21 ;
+22 ; - process patients from selected networks/facilities
+23 SET IBX=""
FOR
SET IBX=$ORDER(IBFAC(IBX))
if IBX=""
QUIT
Begin DoDot:1
+24 SET IBSTN=""
FOR
SET IBSTN=$ORDER(IBFAC(IBX,"C",IBSTN))
if IBSTN=""
QUIT
Begin DoDot:2
+25 ;
+26 ; - get facility/network information
+27 SET IBNET=+$PIECE($PIECE($$VISN^IBATUTL(IBSTN),"^",2)," ",2)
+28 SET IBY=$$INST^IBATUTL(IBSTN)
+29 if $PIECE(IBY,"^",2)=""
SET $PIECE(IBY,"^",2)="<No Sta. #>"
+30 SET IBFACN(IBSTN)=IBY
+31 ;
+32 ; - find all patients from the specific facility
+33 SET DFN=0
FOR
SET DFN=$ORDER(^IBAT(351.6,"AD",IBSTN,DFN))
if 'DFN
QUIT
Begin DoDot:3
+34 DO SET(IBNET,IBSTN,DFN)
End DoDot:3
End DoDot:2
End DoDot:1
+35 ;
PRINT ;
+1 ; now call scheduling to look up future appts
+2 SET IBARRAY(1)=$$NOW^XLFDT_";9999999"
+3 SET IBARRAY(3)="R;I;NT"
+4 SET IBARRAY(4)="^TMP(""IBDFN"",$J,"
+5 SET IBARRAY("SORT")="P"
+6 SET IBARRAY("FLDS")=1
+7 SET IBCOUNT=$$SDAPI^SDAMA301(.IBARRAY)
+8 ;
+9 ; Print the report.
+10 ;
+11 SET (IBPAG,IBQ)=0
DO NOW^%DTC
SET IBRUN=$$DAT2^IBOUTL(%)
+12 ;
+13 IF '$DATA(^TMP("IBATOP",$JOB))
DO HDR(0)
WRITE !!!,"There are no Transfer Pricing patients for the selected networks/facilities."
GOTO ENQ
+14 ;
+15 SET IBNET=""
FOR
SET IBNET=$ORDER(^TMP("IBATOP",$JOB,IBNET))
if IBNET=""!(IBQ)
QUIT
Begin DoDot:1
+16 if IBPAG
DO PAUSE
DO HDR(IBNET)
+17 SET IBSTN=""
FOR
SET IBSTN=$ORDER(^TMP("IBATOP",$JOB,IBNET,IBSTN))
if IBSTN=""!(IBQ)
QUIT
Begin DoDot:2
+18 ;
+19 IF $Y>(IOSL-4)
DO PAUSE
if IBQ
QUIT
DO HDR(IBNET)
+20 DO DISFAC(IBSTN)
+21 ;
+22 SET IBNAM=""
FOR
SET IBNAM=$ORDER(^TMP("IBATOP",$JOB,IBNET,IBSTN,IBNAM))
if IBNAM=""!(IBQ)
QUIT
SET IBXX=$GET(^(IBNAM))
Begin DoDot:3
+23 ;
+24 IF $Y>(IOSL-2)
DO PAUSE
if IBQ
QUIT
DO HDR(IBNET)
DO DISFAC(IBSTN)
+25 ;
+26 WRITE !,$EXTRACT($PIECE(IBNAM,"@@"),1,20)," (",$PIECE(IBXX,"^"),")"
+27 WRITE ?28,$EXTRACT($PIECE(IBXX,"^",2),1,19),?49,$PIECE(IBXX,"^",3),?55,$PIECE(IBXX,"^",4)
+28 WRITE ?61,$SELECT($PIECE(IBXX,"^",5):$$DAT1^IBOUTL($PIECE(IBXX,"^",5)),1:"")
+29 SET IBNDT=$ORDER(^TMP($JOB,"SDAMA301",$PIECE(IBNAM,"@@",2),0))
+30 IF IBNDT
SET $PIECE(IBXX,"^",6)=$SELECT('$PIECE(IBXX,"^",6):IBNDT,IBNDT<$PIECE(IBXX,"^",6):IBNDT,1:$PIECE(IBXX,"^",6))
+31 WRITE ?71,$SELECT($PIECE(IBXX,"^",6):$$DAT1^IBOUTL($PIECE(IBXX,"^",6)),1:"")
End DoDot:3
End DoDot:2
End DoDot:1
+32 ;
+33 IF 'IBQ
DO PAUSE
+34 ;
ENQ KILL ^TMP("IBATOP",$JOB)
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
GOTO ENQ1
+2 ;
+3 DO ^%ZISC
ENQ1 KILL IBPAG,IBD,IBQ,IBRUN,IBNET,IBSTN,IBNAM,IBXX,IBY
+1 KILL IBFAC,IBFACN,IBARR,IBALL,IBX,DFN,POP,X,Y,SDCNT
+2 QUIT
+3 ;
+4 ;
SET(IBNET,IBSTA,DFN) ; Create the temporary sort file.
+1 ; Input: IBNET -- The network/VISN number
+2 ; IBSTA -- The Station number
+3 ; DFN -- Pointer to the patient in file #2
+4 ;
+5 NEW IBDFN,IBINS,IBMT,IBTXMT,VAEL,VAERR
+6 ;
+7 SET IBDFN=$$PT^IBEFUNC(DFN)
+8 SET IBINS=$$INSURED^IBCNS1(DFN)
SET IBMT=$PIECE($$LST^DGMTU(DFN),"^",4)
+9 SET IBMT=$SELECT(IBMT="C":"YES",IBMT="G":"GMT",IBMT="P":"PEN",IBMT="R":"REQ",1:"NO")
+10 SET IBTXMT=$$TXMT(DFN)
+11 DO ELIG^VADPT
+12 ;
+13 ; - set all patients to be included in array for next appt.
+14 IF $$GETICN^MPIF001(DFN)>0
SET ^TMP("IBDFN",$JOB,DFN)=""
+15 ;
+16 ; - set all patient data into the temporary file
+17 SET ^TMP("IBATOP",$JOB,IBNET,IBSTA,$PIECE(IBDFN,"^")_"@@"_DFN)=$PIECE(IBDFN,"^",3)_"^"_$PIECE(VAEL(1),"^",2)_"^"_IBMT_"^"_$SELECT(IBINS:"YES",1:"NO")_"^"_IBTXMT
+18 QUIT
+19 ;
TXMT(DFN) ; Find the patient's last treatment date and next sched date
+1 ; Input: DFN -- Pointer to the patient in file #2
+2 ; Output: 1^2, where
+3 ; 1 => last treatment date, or null
+4 ; 2 => next scheduled treatment date, or null
+5 ; (not including scheduling)
+6 ;
+7 NEW IBDT,IBLT,IBNEXT,IBQ,X,X1,X2
+8 SET (IBLT,IBNEXT)=""
+9 ;
+10 ; - if current inpatient, set last treatment date to today
+11 IF $GET(^DPT(DFN,.105))
SET IBLT=DT
GOTO TXMTN
+12 ;
+13 ; - get the last discharge date
+14 SET IBLT=+$ORDER(^DGPM("ATID3",DFN,""))
if IBLT
SET IBLT=9999999.9999999-IBLT\1
+15 if IBLT>DT
SET IBLT=DT
+16 ;
+17 ; - get the last registration date and compare to last treatment date
+18 SET X=+$ORDER(^DPT(DFN,"DIS",0))
IF X
SET X=9999999-X\1
if X>IBLT
SET IBLT=X
+19 ;
+20 ; - get the last appointment or stop after last treatment date (if any)
+21 KILL ^TMP("DIERR",$JOB)
+22 IF '$GET(IBQ)
Begin DoDot:1
+23 DO OPEN^SDQ(.IBQ)
if '$GET(IBQ)
QUIT
+24 DO INDEX^SDQ(.IBQ,"PATIENT/DATE","SET")
+25 DO SCANCB^SDQ(.IBQ,"I $S($P(SDOE0,U,8)=2:1,$P(SDOE0,U,8)=1:$$APPT^IBATOP(SDOE0),1:0) S IBLT=SDOE0\1,SDSTOP=1","SET")
End DoDot:1
+26 ;
+27 DO PAT^SDQ(.IBQ,DFN,"SET")
+28 DO DATE^SDQ(.IBQ,IBLT+.000001,9999999,"SET")
+29 DO ACTIVE^SDQ(.IBQ,"TRUE","SET")
+30 DO SCAN^SDQ(.IBQ,"BACKWARD")
+31 DO CLOSE^SDQ(.IBQ)
+32 KILL ^TMP("DIERR",$JOB)
+33 ;
TXMTN ; - find next scheduled treatment date
+1 SET IBNEXT=""
+2 ; sched adm
SET X=0
FOR
SET X=$ORDER(^DGS(41.1,"B",DFN,X))
if 'X
QUIT
Begin DoDot:1
+3 SET X1=$GET(^DGS(41.1,X,0))
+4 SET X2=$PIECE(X1,"^",2)\1
+5 ; must be old scheduled adm
if X2<DT
QUIT
+6 ; sched adm is cancelled
if $PIECE(X1,"^",13)
QUIT
+7 ; patient already admitted
if $PIECE(X1,"^",17)
QUIT
+8 IF X2>IBNEXT
SET IBNEXT=X2
End DoDot:1
+9 ;
+10 QUIT IBLT_"^"_IBNEXT
+11 ;
APPT(SDOE0) ; Determine if appt associated with encounter is valid
+1 QUIT $SELECT($PIECE(SDOE0,U,12)=2:1,$PIECE(SDOE0,U,12)=14:1,1:0)
+2 ;
+3 ;
PAUSE ; Page break
+1 if $EXTRACT(IOST,1,2)'="C-"
QUIT
+2 NEW IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
+3 FOR IBX=$Y:1:(IOSL-3)
WRITE !
+4 SET DIR(0)="E"
DO ^DIR
IF $DATA(DIRUT)!($DATA(DUOUT))
SET IBQ=1
+5 QUIT
+6 ;
HDR(IBNET) ; Write the detail report header.
+1 IF $EXTRACT(IOST,1,2)="C-"!(IBPAG)
WRITE @IOF,*13
+2 SET IBPAG=IBPAG+1
+3 WRITE !,"Transfer Pricing Patient Listing",?38,"Run Date: ",IBRUN,?72,"Page: ",IBPAG
+4 IF $GET(IBNET)
WRITE !,"Network: VISN ",IBNET
+5 WRITE !?50,"MT",?55,"Act",?63,"Last",?71,"Nxt Sched"
+6 WRITE !,"Patient Name/ID",?28,"Primary Eligibility",?49,"Stat"
+7 WRITE ?55,"Ins",?63,"Seen",?71,"Visit/Adm"
+8 WRITE !,$$DASH(IOM)
+9 QUIT
+10 ;
DISFAC(X) ; Display the station number and name.
+1 ; Input: X -- The Station Number
+2 ; Variable input: IBFACN array
+3 ;
+4 WRITE !!?4,"Home Facility: ",$PIECE(IBFACN(X),"^",2)," ",$PIECE(IBFACN(X),"^"),!
+5 QUIT
+6 ;
DASH(X) ; Return a dashed line.
+1 QUIT $TRANSLATE($JUSTIFY("",X)," ","=")
