- 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 Mar 13, 2025@21:27:58 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
