IBJDF62 ;ALB/RB - MISC. BILLS FOLLOW-UP REPORT (PRINT) ;15-APR-00
;;2.0;INTEGRATED BILLING;**123,159,618**;21-MAR-94;Build 61
;;Per VHA Directive 6402, this routine should not be modified.
;
;Read ^PRCA(430.2) via Private IA 594
;
EN ; - Print the Follow-up report.
S IBQ=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%) G:IBRPT="S" SUM
I 'IBSDV D DET(0) G SUM
S IBDIV=""
F S IBDIV=$O(VAUTD(IBDIV)) Q:IBDIV="" D Q:IBQ
. D DET(IBDIV)
;
SUM I 'IBQ D PRT^IBJDF63 ; Print summary.
ENQ K IBN,IBIN,IBC,IBCD,IBC1,IBC2,IBCAT1,IBD,IBDIV,IBGBL,IBPAG,IBP,IBPD,IBPTD,IBQ,IBRUN,%
Q
;
DET(IBDIV) ; - Print report for a specific division.
; Input: IBDIV=Pointer to the division in file #40.8
S IBCAT=0
F S IBCAT=$O(IBCAT(IBCAT)) Q:'IBCAT D Q:IBQ
. S IBCAT1=IBCAT(IBCAT),IBGBL=$S(IBCAT1<8:"IBJDF6P",1:"IBJDF6D") ;IB*2.0*618
. I IBDIV,IBCAT1'<8 Q ;IB*2.0*618
. I IBSDV,'IBDIV,IBCAT1<8 Q ;IB*2.0*618
. I '$D(^TMP(IBGBL,$J,IBDIV,IBCAT)) D HDR1 Q:IBQ D NAR,PAUSE Q
. D HDR1 Q:IBQ
. S IBIN="" F S IBIN=$O(^TMP(IBGBL,$J,IBDIV,IBCAT,IBIN)) Q:IBIN="" D Q:IBQ
. . I $Y>(IOSL-5) D PAUSE Q:IBQ D HDR1 Q:IBQ
. . D HDR2
. . S (IBPTD,IB0,IBD)=""
. . F S IBPTD=$O(^TMP(IBGBL,$J,IBDIV,IBCAT,IBIN,IBPTD)) Q:IBPTD="" D Q:IBQ
. . . I $Y>(IOSL-5) D PAUSE Q:IBQ D HDR1,HDR2 Q:IBQ
. . . S IBPD=$G(^TMP(IBGBL,$J,IBDIV,IBCAT,IBIN,IBPTD))
. . . D WPAT
. . . F S IB0=$O(^TMP(IBGBL,$J,IBDIV,IBCAT,IBIN,IBPTD,IB0)) Q:IB0="" D Q:IBQ
. . . . S IBN=$G(^TMP(IBGBL,$J,IBDIV,IBCAT,IBIN,IBPTD,IB0))
. . . . I $Y>(IOSL-3) D PAUSE Q:IBQ D HDR1,HDR2 Q:IBQ D WPAT
. . . . I IBCAT1<8 D ;IB*2.0*618
. . . . . W ?71,IB0,?84,$$DAT1^IBOUTL(+IBN),?94,$$DAT1^IBOUTL($P(IBN,U,2))
. . . . . W ?104,$$DAT1^IBOUTL($P(IBN,U,3)),?114,$J($P(IBN,U,4),8,2)
. . . . . W ?124,$J($P(IBN,U,5),8,2),!
. . . . E D
. . . . . W ?33,IB0,?47,$$DAT1^IBOUTL(+IBN),?59,$P($P(IBN,U,2),"@@")
. . . . . W ?92,$J($P(IBN,U,3),8,2),?103,$J($P(IBN,U,4),8,2)
. . . . . W ?114,$J($P(IBN,U,5),8,2),!
. . . . ;
. . . . ; - Display bill comment history, if necessary.
. . . . I IBSH D COM
. ;
. I 'IBQ D PAUSE
;
DETQ Q
;
DASH(X) ; - Return a dashed line.
Q $TR($J("",X)," ","=")
;
PAUSE ; - Page break.
I $E(IOST,1,2)'="C-" Q
N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
F IBX=$Y:1:(IOSL-3) W !
S DIR(0)="E" D ^DIR S:$D(DIRUT)!($D(DUOUT)) IBQ=1
Q
;
HDR1 ; - Write the primary report header.
N IBCATNM
I $E(IOST,1,2)="C-"!$G(IBPAG) W @IOF,*13
S IBPAG=$G(IBPAG)+1 W "Miscellaneous Bills Follow-Up Report"
I IBDIV W " for ",$P($G(^DG(40.8,IBDIV,0)),U)
W ?60," Run Date: ",IBRUN,?123,"Page: ",$J(IBPAG,3)
;
S IBCATNM=$$ARCAT(IBCAT) ; patch IB*2.0*618
S X="ALL ACTIVE "_$G(IBCATNM)_" RECEIVABLES "
I IBSMN S X=X_"OVER "_IBSMN_" AND LESS THAN "_IBSMX_" DAYS OLD "
I IBCAT(IBCAT)<8 D ;IB*2.0*618
. S X=X_" / BY PATIENT "_$S(IBSN="N":"NAME",1:"LAST 4 DIGITS OF SSN")
. S X=X_" ("_$S($G(IBSNA)="ALL":"ALL",1:"From "_$S(IBSNF="":"FIRST",1:IBSNF)_" to "_$S(IBSNL="zzzzz":"LAST",1:IBSNL))_") / "
I IBCAT(IBCAT)>7 D ;IB*2.0*618
. S X=X_" / BY DEBTOR NAME"
. S X=X_" ("_$S($G(IBSDA)="ALL":"ALL",1:"From "_$S(IBSDF="":"FIRST",1:IBSDF)_" to "_$S(IBSDL="zzzzz":"LAST",1:IBSDL))_") / "
S X=X_$S('IBSAM:"NO ",1:"")_" MINIMUM BALANCE"
I IBSAM S X=X_$S(IBSAM:": $"_$FN(IBSAM,",",2),1:"")
S X=X_" / "_$S('IBSH:"NO ",IBSH1="A":"ALL ",1:"ONLY ")_"COMMENTS"
S X=X_$S($G(IBSH2):" NOT OLDER THAN "_IBSH2_" DAYS",1:"")
S X=X_" / '*' AFTER THE PATIENT/DEBTOR NAME = VA EMPLOYEE"
F I=1:1 W !,$E(X,1,132) S X=$E(X,133,999) I X="" Q
;
I IBCAT1<8 D G HDQ ;IB*2.0*618
.W !!?84,"Date",?94,"Bill",?104,"Bill",?114,"Original Current"
.W !,"Patient (Age)",?33,"SSN",?47,"Other Insurance",?71,"Bill Number"
.W ?84,"Prepared From Dte To Date",?116,"Amount Balance"
;
W !!?47,"Date Bill",?92,"Original Last Amt Current"
W !,"Debtor",?33,"Bill Number Prepared Processed By",?94,"Amount"
W ?107,"Paid Balance" S:$G(IBD) IBD=""
HDQ W !,$$DASH(IOM),!
S IBQ=$$STOP^IBOUTL("Miscellaneous Bills Follow-Up Report")
Q
;
HDR2 ; - Write the insurance company sub-header.
N X,X13 Q:IBCAT1>7 ;IB*2.0*618
W ?2,"Carrier: ",$P(IBIN,"@@")
S X=$G(^DIC(36,+$P(IBIN,"@@",2),.11)),X13=$G(^(.13))
I X]"" D
.W ", ",$P(X,U),", ",$P(X,U,4),", ",$P($G(^DIC(5,+$P(X,U,5),0)),U,2)," ",$P(X,U,6)
.I $P(X13,U,2)]"" W " Billing Phone: ",$P(X13,U,2) Q
.I $P(X13,U)]"" W " Main Phone: ",$P(X13,U)
;
W !
Q
;
NAR ; - Write detail line (if '$D).
N I
W !!,"There are no active receivables "
I IBSMN W IBSMN,$S(IBSMX>IBSMN:" to "_IBSMX,1:"")," days old "
I IBDIV W "for this division."
I IBSDV,IBDIV,IBCAT1<8 Q ;IB*2.0*618
I IBSDV,'IBDIV,IBCAT1'<8 Q ;IB*2.0*618
F I=1:1:8 S IB(+IBDIV,IBCAT,I)=""
Q
;
WPAT ; - Write patient data.
I IBCAT1<8 D Q ;IB*2.0*618
. W $P(IBPD,U)," (",$P(IBPD,U,2),")",?33,$P(IBPD,U,3),?47,$P(IBPD,U,4)
W $P(IBPD,U)
Q
;
COM ; - Write comments
N CONT,DIWL,DIWR,IBC,IBC1,IBC2,X
;
S (IBC,CONT)=0,IBC1="",DIWL=1,DIWR=104 K ^UTILITY($J,"W")
F S IBC=$O(^TMP(IBGBL,$J,IBDIV,IBCAT,IBIN,IBPTD,IB0,IBC)) Q:'IBC D Q:IBQ
. I $Y>(IOSL-4) D PAUSE Q:IBQ D HDR1,HDR2 Q:IBQ D WPAT W !
. F S IBC1=$O(^TMP(IBGBL,$J,IBDIV,IBCAT,IBIN,IBPTD,IB0,IBC,IBC1)) Q:IBC1="" D Q:IBQ
. . S IBC2=^TMP(IBGBL,$J,IBDIV,IBCAT,IBIN,IBPTD,IB0,IBC,IBC1)
. . I $Y>(IOSL-4) D WCPB Q:IBQ
. . I 'IBC1 S IBCD=IBC2 D WCD Q
. . S X=IBC2 I $E(X)=" ",$L(X)>1 S $E(X)=""
. . D ^DIWP
. . I 'CONT,$L(IBC2)<66 D WCTXT Q
. . S CONT=$L(IBC2)>65
. . I '$O(^TMP(IBGBL,$J,IBDIV,IBCAT,IBIN,IBPTD,IB0,IBC,IBC1)) D
. . . D:$D(^UTILITY($J,"W")) WCTXT
K ^UTILITY($J,"W")
Q
;
WCTXT ; - Write comment text
N LIN,WLIN
S LIN=""
F S LIN=$O(^UTILITY($J,"W",1,LIN)) Q:LIN="" D Q:IBQ
. S WLIN=$G(^UTILITY($J,"W",1,LIN,0))
. I $Y>(IOSL-4) D WCPB Q:IBQ
. W:WLIN'="" ?26,WLIN,!
K ^UTILITY($J,"W")
Q
;
WCPB ; - Page Break in the middle of Comments
D PAUSE Q:IBQ D HDR1,HDR2 Q:IBQ
W ! D WPAT W ! D WCD W:IBC1>1 ?26,"(continued)",!
Q
;
WCD ; - Write comment date.
W ?2,"Comment Date: ",$$DAT1^IBOUTL(IBCD)
Q
;
ARCAT(IBCAT) ; obtain AR Category's name - patch IB*2.0*618
N IBCATNAM
S IBCATNAM=$$GET1^DIQ(430.2,IBCAT,.01) ; get AR CATEGORY
Q IBCATNAM
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDF62 6327 printed Dec 13, 2024@02:22:59 Page 2
IBJDF62 ;ALB/RB - MISC. BILLS FOLLOW-UP REPORT (PRINT) ;15-APR-00
+1 ;;2.0;INTEGRATED BILLING;**123,159,618**;21-MAR-94;Build 61
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ;Read ^PRCA(430.2) via Private IA 594
+5 ;
EN ; - Print the Follow-up report.
+1 SET IBQ=0
DO NOW^%DTC
SET IBRUN=$$DAT2^IBOUTL(%)
if IBRPT="S"
GOTO SUM
+2 IF 'IBSDV
DO DET(0)
GOTO SUM
+3 SET IBDIV=""
+4 FOR
SET IBDIV=$ORDER(VAUTD(IBDIV))
if IBDIV=""
QUIT
Begin DoDot:1
+5 DO DET(IBDIV)
End DoDot:1
if IBQ
QUIT
+6 ;
SUM ; Print summary.
IF 'IBQ
DO PRT^IBJDF63
ENQ KILL IBN,IBIN,IBC,IBCD,IBC1,IBC2,IBCAT1,IBD,IBDIV,IBGBL,IBPAG,IBP,IBPD,IBPTD,IBQ,IBRUN,%
+1 QUIT
+2 ;
DET(IBDIV) ; - Print report for a specific division.
+1 ; Input: IBDIV=Pointer to the division in file #40.8
+2 SET IBCAT=0
+3 FOR
SET IBCAT=$ORDER(IBCAT(IBCAT))
if 'IBCAT
QUIT
Begin DoDot:1
+4 ;IB*2.0*618
SET IBCAT1=IBCAT(IBCAT)
SET IBGBL=$SELECT(IBCAT1<8:"IBJDF6P",1:"IBJDF6D")
+5 ;IB*2.0*618
IF IBDIV
IF IBCAT1'<8
QUIT
+6 ;IB*2.0*618
IF IBSDV
IF 'IBDIV
IF IBCAT1<8
QUIT
+7 IF '$DATA(^TMP(IBGBL,$JOB,IBDIV,IBCAT))
DO HDR1
if IBQ
QUIT
DO NAR
DO PAUSE
QUIT
+8 DO HDR1
if IBQ
QUIT
+9 SET IBIN=""
FOR
SET IBIN=$ORDER(^TMP(IBGBL,$JOB,IBDIV,IBCAT,IBIN))
if IBIN=""
QUIT
Begin DoDot:2
+10 IF $Y>(IOSL-5)
DO PAUSE
if IBQ
QUIT
DO HDR1
if IBQ
QUIT
+11 DO HDR2
+12 SET (IBPTD,IB0,IBD)=""
+13 FOR
SET IBPTD=$ORDER(^TMP(IBGBL,$JOB,IBDIV,IBCAT,IBIN,IBPTD))
if IBPTD=""
QUIT
Begin DoDot:3
+14 IF $Y>(IOSL-5)
DO PAUSE
if IBQ
QUIT
DO HDR1
DO HDR2
if IBQ
QUIT
+15 SET IBPD=$GET(^TMP(IBGBL,$JOB,IBDIV,IBCAT,IBIN,IBPTD))
+16 DO WPAT
+17 FOR
SET IB0=$ORDER(^TMP(IBGBL,$JOB,IBDIV,IBCAT,IBIN,IBPTD,IB0))
if IB0=""
QUIT
Begin DoDot:4
+18 SET IBN=$GET(^TMP(IBGBL,$JOB,IBDIV,IBCAT,IBIN,IBPTD,IB0))
+19 IF $Y>(IOSL-3)
DO PAUSE
if IBQ
QUIT
DO HDR1
DO HDR2
if IBQ
QUIT
DO WPAT
+20 ;IB*2.0*618
IF IBCAT1<8
Begin DoDot:5
+21 WRITE ?71,IB0,?84,$$DAT1^IBOUTL(+IBN),?94,$$DAT1^IBOUTL($PIECE(IBN,U,2))
+22 WRITE ?104,$$DAT1^IBOUTL($PIECE(IBN,U,3)),?114,$JUSTIFY($PIECE(IBN,U,4),8,2)
+23 WRITE ?124,$JUSTIFY($PIECE(IBN,U,5),8,2),!
End DoDot:5
+24 IF '$TEST
Begin DoDot:5
+25 WRITE ?33,IB0,?47,$$DAT1^IBOUTL(+IBN),?59,$PIECE($PIECE(IBN,U,2),"@@")
+26 WRITE ?92,$JUSTIFY($PIECE(IBN,U,3),8,2),?103,$JUSTIFY($PIECE(IBN,U,4),8,2)
+27 WRITE ?114,$JUSTIFY($PIECE(IBN,U,5),8,2),!
End DoDot:5
+28 ;
+29 ; - Display bill comment history, if necessary.
+30 IF IBSH
DO COM
End DoDot:4
if IBQ
QUIT
End DoDot:3
if IBQ
QUIT
End DoDot:2
if IBQ
QUIT
+31 ;
+32 IF 'IBQ
DO PAUSE
End DoDot:1
if IBQ
QUIT
+33 ;
DETQ QUIT
+1 ;
DASH(X) ; - Return a dashed line.
+1 QUIT $TRANSLATE($JUSTIFY("",X)," ","=")
+2 ;
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 ;
HDR1 ; - Write the primary report header.
+1 NEW IBCATNM
+2 IF $EXTRACT(IOST,1,2)="C-"!$GET(IBPAG)
WRITE @IOF,*13
+3 SET IBPAG=$GET(IBPAG)+1
WRITE "Miscellaneous Bills Follow-Up Report"
+4 IF IBDIV
WRITE " for ",$PIECE($GET(^DG(40.8,IBDIV,0)),U)
+5 WRITE ?60," Run Date: ",IBRUN,?123,"Page: ",$JUSTIFY(IBPAG,3)
+6 ;
+7 ; patch IB*2.0*618
SET IBCATNM=$$ARCAT(IBCAT)
+8 SET X="ALL ACTIVE "_$GET(IBCATNM)_" RECEIVABLES "
+9 IF IBSMN
SET X=X_"OVER "_IBSMN_" AND LESS THAN "_IBSMX_" DAYS OLD "
+10 ;IB*2.0*618
IF IBCAT(IBCAT)<8
Begin DoDot:1
+11 SET X=X_" / BY PATIENT "_$SELECT(IBSN="N":"NAME",1:"LAST 4 DIGITS OF SSN")
+12 SET X=X_" ("_$SELECT($GET(IBSNA)="ALL":"ALL",1:"From "_$SELECT(IBSNF="":"FIRST",1:IBSNF)_" to "_$SELECT(IBSNL="zzzzz":"LAST",1:IBSNL))_") / "
End DoDot:1
+13 ;IB*2.0*618
IF IBCAT(IBCAT)>7
Begin DoDot:1
+14 SET X=X_" / BY DEBTOR NAME"
+15 SET X=X_" ("_$SELECT($GET(IBSDA)="ALL":"ALL",1:"From "_$SELECT(IBSDF="":"FIRST",1:IBSDF)_" to "_$SELECT(IBSDL="zzzzz":"LAST",1:IBSDL))_") / "
End DoDot:1
+16 SET X=X_$SELECT('IBSAM:"NO ",1:"")_" MINIMUM BALANCE"
+17 IF IBSAM
SET X=X_$SELECT(IBSAM:": $"_$FNUMBER(IBSAM,",",2),1:"")
+18 SET X=X_" / "_$SELECT('IBSH:"NO ",IBSH1="A":"ALL ",1:"ONLY ")_"COMMENTS"
+19 SET X=X_$SELECT($GET(IBSH2):" NOT OLDER THAN "_IBSH2_" DAYS",1:"")
+20 SET X=X_" / '*' AFTER THE PATIENT/DEBTOR NAME = VA EMPLOYEE"
+21 FOR I=1:1
WRITE !,$EXTRACT(X,1,132)
SET X=$EXTRACT(X,133,999)
IF X=""
QUIT
+22 ;
+23 ;IB*2.0*618
IF IBCAT1<8
Begin DoDot:1
+24 WRITE !!?84,"Date",?94,"Bill",?104,"Bill",?114,"Original Current"
+25 WRITE !,"Patient (Age)",?33,"SSN",?47,"Other Insurance",?71,"Bill Number"
+26 WRITE ?84,"Prepared From Dte To Date",?116,"Amount Balance"
End DoDot:1
GOTO HDQ
+27 ;
+28 WRITE !!?47,"Date Bill",?92,"Original Last Amt Current"
+29 WRITE !,"Debtor",?33,"Bill Number Prepared Processed By",?94,"Amount"
+30 WRITE ?107,"Paid Balance"
if $GET(IBD)
SET IBD=""
HDQ WRITE !,$$DASH(IOM),!
+1 SET IBQ=$$STOP^IBOUTL("Miscellaneous Bills Follow-Up Report")
+2 QUIT
+3 ;
HDR2 ; - Write the insurance company sub-header.
+1 ;IB*2.0*618
NEW X,X13
if IBCAT1>7
QUIT
+2 WRITE ?2,"Carrier: ",$PIECE(IBIN,"@@")
+3 SET X=$GET(^DIC(36,+$PIECE(IBIN,"@@",2),.11))
SET X13=$GET(^(.13))
+4 IF X]""
Begin DoDot:1
+5 WRITE ", ",$PIECE(X,U),", ",$PIECE(X,U,4),", ",$PIECE($GET(^DIC(5,+$PIECE(X,U,5),0)),U,2)," ",$PIECE(X,U,6)
+6 IF $PIECE(X13,U,2)]""
WRITE " Billing Phone: ",$PIECE(X13,U,2)
QUIT
+7 IF $PIECE(X13,U)]""
WRITE " Main Phone: ",$PIECE(X13,U)
End DoDot:1
+8 ;
+9 WRITE !
+10 QUIT
+11 ;
NAR ; - Write detail line (if '$D).
+1 NEW I
+2 WRITE !!,"There are no active receivables "
+3 IF IBSMN
WRITE IBSMN,$SELECT(IBSMX>IBSMN:" to "_IBSMX,1:"")," days old "
+4 IF IBDIV
WRITE "for this division."
+5 ;IB*2.0*618
IF IBSDV
IF IBDIV
IF IBCAT1<8
QUIT
+6 ;IB*2.0*618
IF IBSDV
IF 'IBDIV
IF IBCAT1'<8
QUIT
+7 FOR I=1:1:8
SET IB(+IBDIV,IBCAT,I)=""
+8 QUIT
+9 ;
WPAT ; - Write patient data.
+1 ;IB*2.0*618
IF IBCAT1<8
Begin DoDot:1
+2 WRITE $PIECE(IBPD,U)," (",$PIECE(IBPD,U,2),")",?33,$PIECE(IBPD,U,3),?47,$PIECE(IBPD,U,4)
End DoDot:1
QUIT
+3 WRITE $PIECE(IBPD,U)
+4 QUIT
+5 ;
COM ; - Write comments
+1 NEW CONT,DIWL,DIWR,IBC,IBC1,IBC2,X
+2 ;
+3 SET (IBC,CONT)=0
SET IBC1=""
SET DIWL=1
SET DIWR=104
KILL ^UTILITY($JOB,"W")
+4 FOR
SET IBC=$ORDER(^TMP(IBGBL,$JOB,IBDIV,IBCAT,IBIN,IBPTD,IB0,IBC))
if 'IBC
QUIT
Begin DoDot:1
+5 IF $Y>(IOSL-4)
DO PAUSE
if IBQ
QUIT
DO HDR1
DO HDR2
if IBQ
QUIT
DO WPAT
WRITE !
+6 FOR
SET IBC1=$ORDER(^TMP(IBGBL,$JOB,IBDIV,IBCAT,IBIN,IBPTD,IB0,IBC,IBC1))
if IBC1=""
QUIT
Begin DoDot:2
+7 SET IBC2=^TMP(IBGBL,$JOB,IBDIV,IBCAT,IBIN,IBPTD,IB0,IBC,IBC1)
+8 IF $Y>(IOSL-4)
DO WCPB
if IBQ
QUIT
+9 IF 'IBC1
SET IBCD=IBC2
DO WCD
QUIT
+10 SET X=IBC2
IF $EXTRACT(X)=" "
IF $LENGTH(X)>1
SET $EXTRACT(X)=""
+11 DO ^DIWP
+12 IF 'CONT
IF $LENGTH(IBC2)<66
DO WCTXT
QUIT
+13 SET CONT=$LENGTH(IBC2)>65
+14 IF '$ORDER(^TMP(IBGBL,$JOB,IBDIV,IBCAT,IBIN,IBPTD,IB0,IBC,IBC1))
Begin DoDot:3
+15 if $DATA(^UTILITY($JOB,"W"))
DO WCTXT
End DoDot:3
End DoDot:2
if IBQ
QUIT
End DoDot:1
if IBQ
QUIT
+16 KILL ^UTILITY($JOB,"W")
+17 QUIT
+18 ;
WCTXT ; - Write comment text
+1 NEW LIN,WLIN
+2 SET LIN=""
+3 FOR
SET LIN=$ORDER(^UTILITY($JOB,"W",1,LIN))
if LIN=""
QUIT
Begin DoDot:1
+4 SET WLIN=$GET(^UTILITY($JOB,"W",1,LIN,0))
+5 IF $Y>(IOSL-4)
DO WCPB
if IBQ
QUIT
+6 if WLIN'=""
WRITE ?26,WLIN,!
End DoDot:1
if IBQ
QUIT
+7 KILL ^UTILITY($JOB,"W")
+8 QUIT
+9 ;
WCPB ; - Page Break in the middle of Comments
+1 DO PAUSE
if IBQ
QUIT
DO HDR1
DO HDR2
if IBQ
QUIT
+2 WRITE !
DO WPAT
WRITE !
DO WCD
if IBC1>1
WRITE ?26,"(continued)",!
+3 QUIT
+4 ;
WCD ; - Write comment date.
+1 WRITE ?2,"Comment Date: ",$$DAT1^IBOUTL(IBCD)
+2 QUIT
+3 ;
ARCAT(IBCAT) ; obtain AR Category's name - patch IB*2.0*618
+1 NEW IBCATNAM
+2 ; get AR CATEGORY
SET IBCATNAM=$$GET1^DIQ(430.2,IBCAT,.01)
+3 QUIT IBCATNAM
