IBCMDT3 ;ALB/VD - INSURANCE PLANS MISSING DATA REPORT (PRINT) ; 10-APR-15
;;2.0;INTEGRATED BILLING ;**549,827**;21-MAR-94;Build 24
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to ^%DTC in ICR #10000
; Reference to ^DIR in ICR #10026
;
; Print the report.
; Required Input: Global print array ^TMP($J,"PR"
;
;
EN ; - Entry point to print report
N EORMSG,IBHDT,NODATA
N IBQUIT S IBQUIT=0 ;IB*827/DTG move new and set of IBQUIT from PRINT to here
N IBXTFEED,IBLNC,MAXCNT S (IBXTFEED,IBLNC,MAXCNT)="" ;IB*827/DTG new var's for line feeds and page breaks
S MAXCNT=IOSL-3,IBXTFEED=21,IBLNC=0 ;IB*827/DTG correct line feeds
I 'CRT S MAXCNT=IOSL-5,IBXTFEED=50
S EORMSG="*** END OF REPORT ***"
D NOW^%DTC S IBHDT=$$DAT2^IBOUTL($E(%,1,12))
S NODATA=1
D PRINT
K ^TMP($J,"PR"),^TMP("IBCMDT",IBNMSPC)
I NODATA D
. N IBPAG
. S IBPAG=0
. D COMP
;IB*827/DTG manage EOR for IBQUIT
;W !!!,EORMSG
;D PAUSE
I IBQUIT W !
I 'IBQUIT D
. W !!!,EORMSG
. D PAUSE
;
I $D(ZTQUEUED) S ZTREQ="@" Q
; Close Device
D ^%ZISC
Q
;
PRINT ; Print report
; Input: NODATA - Set to 1 initially
; Output: NODATE - Set to 1 if at least one Insurance Company
; with data found
;N CVLMRC,CVLPRT,CVSWT,IBC,IBCVLT,IBI,IBP,IBPAG,IBQUIT,NEWIC,POSWT,%
N CVLMRC,CVLPRT,CVSWT,IBC,IBCVLT,IBI,IBP,IBPAG,NEWIC,POSWT,% ;IB*827/DTG move new of IBQUIT to EN
;
N IBOINS S IBOINS="" ;IB*827/DTG new var for line feeds and page breaks
;
N IBOLK S IBOLK=0 ;IB*827/DTG new counter for pause
S (IBI,IBQUIT,IBPAG,CVLPRT,POSWT)=0,IBCVLT=""
F S IBI=$O(^TMP($J,"PR",IBI)) Q:('IBI!IBQUIT) D
. S IBC=$G(^TMP($J,"PR",IBI)),POSWT=+$P(IBC,U,1)
. I $D(^TMP($J,"PR",IBI))=1 Q
. S NODATA=0
. ;D COMP D Q:IBQUIT
. D P0 Q:IBQUIT D Q:IBQUIT ;IB*827/DTG increase checks for line pause
. . S IBP=0
. . S IBOLK=0,CVLPRT=0 ;IB*TBD/XXX value for pause
. . ; plan
. . ;F S IBP=$O(^TMP($J,"PR",IBI,IBP)) Q:'IBP D Q:IBQUIT
. . F S IBP=$O(^TMP($J,"PR",IBI,IBP)) D:('IBP&('IBOLK)) P1 Q:'IBP D Q:IBQUIT ;IB*827/DTG value for pause
. . . S IBPD=$G(^TMP($J,"PR",IBI,IBP))
. . . ;I $Y>(IOSL-5) D PAUSE Q:IBQUIT D COMP
. . . I $Y>(MAXCNT-($S('NEWIC:5,1:1))) D PAUSE Q:IBQUIT S CVLPRT=0,IBOLK=1,IBOINS=0 D COMP S IBOINS=1 ;IB*827/DTG value for pause
. . . S CVSWT=1 D PLAN
. . . ; coverage
. . . S IBCVLT=""
. . . F S IBCVLT=$O(^TMP($J,"PR",IBI,IBP,IBCVLT)) Q:IBCVLT="" D Q:IBQUIT
. . . . S CVLMRC=$G(^TMP($J,"PR",IBI,IBP,IBCVLT))
. . . . I $Y>(MAXCNT-($S(+CVSWT:4,1:0))) D PAUSE Q:IBQUIT S CVLPRT=0,IBOLK=1,IBOINS=0 D COMP,PLAN,CVLMHD:'CVSWT S IBOINS=1 ;IB*827/DTG value for pause
. . . . I +CVSWT D CVLMHD S CVSWT=0
. . . . ;IB*827/DTG correct so that lines are in the capture buffer
. . . . ;W !?4,$P(CVLMRC,U,1),?30,$P(CVLMRC,U,2),?50,$P(CVLMRC,U,3)
. . . . W ?4,$P(CVLMRC,U,1),?30,$P(CVLMRC,U,2),?50,$P(CVLMRC,U,3),!
. . . . I $Y>MAXCNT D PAUSE Q:IBQUIT S CVLPRT=0,IBOLK=1,IBOINS=0 D COMP,PLAN,CVLMHD S IBOINS=1 ;IB*827/DTG value for pause
. . . . S CVLPRT=1
;
;IB*827/DTG move new of IBQUIT to EN
;K IBC,IBCVLM,IBI,IBJJ,IBQUIT,IBP,IBPAG,IBPD,IBS,IBSD
K IBC,IBCVLM,IBI,IBJJ,IBP,IBPAG,IBPD,IBS,IBSD
Q
;
COMP ; Print Company header
I IBOINS=1 W !! D COMPS S NEWIC=1 Q ;IB*827/DTG for page breaks.
; Input: NODATA - 1 if no data was found
I CRT!(IBPAG) W @IOF
S IBPAG=IBPAG+1
;IB*TBD/XXX fix extra line feed at top of display
;W !,"INSURANCE PLANS MISSING DATA"
I 'CRT W !
W "INSURANCE PLANS MISSING DATA"
;IB*827/DTG correct so that lines are in the capture buffer
;W ?80,IBHDT,?110,"Page: ",IBPAG
;W !,$G(SUBHD),!
W ?80,IBHDT,?110,"Page: ",IBPAG,!
W $G(SUBHD),!!
I +$G(NODATA) D Q
. W !!!,"--- No Data To Report ---",!
;
D COMPS ;IB*827/DTG moved co info for page breaks.
; - sub-header
;W !?1,$P(IBC,U,2)_" "_$P(IBC,U,3)_" "_$P(IBC,U,4)
;I +POSWT W ?90,"PRESCRIPTION ONLY"
S NEWIC=1
Q
;
COMPS ; Print Company SUB header
;
; - sub-header
;IB*827/DTG correct so that lines are in the capture buffer
W ?1,$P(IBC,U,2)_" "_$P(IBC,U,3)_" "_$P(IBC,U,4)
I +POSWT W ?90,"PRESCRIPTION ONLY"
W !
Q
;
PLAN ; Print plan information.
I CVLPRT W ! S CVLPRT=0
I +NEWIC D
. ;W !!?2,"GROUP NUMBER",?20,"GROUP NAME",?46,"TYPE OF PLAN",?62,"ELEC PLAN",?78,"FTF"
. W !?2,"GROUP NUMBER",?20,"GROUP NAME",?46,"TYPE OF PLAN",?62,"ELEC PLAN",?78,"FTF" ;IB*827/DTG line feeds
. ;W:+$G(POSWT) ?98,"BIN",?109,"PCN"
. W:+$G(POSWT) ?98,"BIN",?109,"PCN" W !
. ;W !?2,"------------",?20,"----------",?46,"------------",?62,"---------",?78,"---"
. W ?2,"------------",?20,"----------",?46,"------------",?62,"---------",?78,"---" ;IB*827/DTG line feeds
. ;W:+$G(POSWT) ?98,"---",?109,"---"
. W:+$G(POSWT) ?98,"---",?109,"---" W ! ;IB*827/DTG line feeds
;W !?2,$P(IBPD,U,2),?20,$E($P(IBPD,U,3),1,25),?46,$E($P(IBPD,U,4),1,15)
W ?2,$P(IBPD,U,2),?20,$E($P(IBPD,U,3),1,25),?46,$E($P(IBPD,U,4),1,15) ;IB*827/DTG line feeds
W ?62,$E($P(IBPD,U,5),1,15),?78,$P(IBPD,U,6)
W:+$G(POSWT) ?98,$P(IBPD,U,7),?109,$P(IBPD,U,8)
W ! ;IB*827/DTG correct so that lines are in the capture buffer
;
S NEWIC=0
Q
;
CVLMHD ; Print Coverage Limit sub-header
;W !!?4,"Coverage",?30,"Effective Date",?50,"Covered?"
W !?4,"Coverage",?30,"Effective Date",?50,"Covered?",! ;IB*827/DTG line feeds
;W !?4,"--------",?30,"--------------",?50,"--------"
W ?4,"--------",?30,"--------------",?50,"--------" ;IB*827/DTG line feeds
W ! ;IB*827/DTG correct so that lines are in the capture buffer
Q
;
P0 ; IB*827/DTG IBI check before pause
;
N IBAC S IBAC=0
I IBOINS=1&(IBOLK=1) S IBAC=1
I $Y>(MAXCNT-7) S IBOINS=0
I IBAC&('IBOINS) D PAUSE Q:IBQUIT
D COMP
S IBOINS=1
Q
;
P1 ; IB*827/DTG IBP check before pause
I $Y>(MAXCNT-($S('NEWIC:5,1:1))) D PAUSE
Q
;
PAUSE ; Pause for screen output.
N IBJJ,DIR,DIRUT,DTOUT,DUOUT ;IB*TBD/XXX correct newing
;Q:$E(IOST,1,2)'["C-"
;F IBJJ=$Y:1:(IOSL-7) W !
F IBJJ=$Y:1:IBXTFEED W ! ;IB*827/DTG don't allow to many line feeds
Q:'CRT ;IB*827/DTG need linefeeds if printed
S DIR(0)="E" D ^DIR K DIR
I $D(DIRUT)!($D(DUOUT)) S IBQUIT=1 K DIRUT,DTOUT,DUOUT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCMDT3 6257 printed Jul 22, 2026@15:22:27 Page 2
IBCMDT3 ;ALB/VD - INSURANCE PLANS MISSING DATA REPORT (PRINT) ; 10-APR-15
+1 ;;2.0;INTEGRATED BILLING ;**549,827**;21-MAR-94;Build 24
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to ^%DTC in ICR #10000
+5 ; Reference to ^DIR in ICR #10026
+6 ;
+7 ; Print the report.
+8 ; Required Input: Global print array ^TMP($J,"PR"
+9 ;
+10 ;
EN ; - Entry point to print report
+1 NEW EORMSG,IBHDT,NODATA
+2 ;IB*827/DTG move new and set of IBQUIT from PRINT to here
NEW IBQUIT
SET IBQUIT=0
+3 ;IB*827/DTG new var's for line feeds and page breaks
NEW IBXTFEED,IBLNC,MAXCNT
SET (IBXTFEED,IBLNC,MAXCNT)=""
+4 ;IB*827/DTG correct line feeds
SET MAXCNT=IOSL-3
SET IBXTFEED=21
SET IBLNC=0
+5 IF 'CRT
SET MAXCNT=IOSL-5
SET IBXTFEED=50
+6 SET EORMSG="*** END OF REPORT ***"
+7 DO NOW^%DTC
SET IBHDT=$$DAT2^IBOUTL($EXTRACT(%,1,12))
+8 SET NODATA=1
+9 DO PRINT
+10 KILL ^TMP($JOB,"PR"),^TMP("IBCMDT",IBNMSPC)
+11 IF NODATA
Begin DoDot:1
+12 NEW IBPAG
+13 SET IBPAG=0
+14 DO COMP
End DoDot:1
+15 ;IB*827/DTG manage EOR for IBQUIT
+16 ;W !!!,EORMSG
+17 ;D PAUSE
+18 IF IBQUIT
WRITE !
+19 IF 'IBQUIT
Begin DoDot:1
+20 WRITE !!!,EORMSG
+21 DO PAUSE
End DoDot:1
+22 ;
+23 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+24 ; Close Device
+25 DO ^%ZISC
+26 QUIT
+27 ;
PRINT ; Print report
+1 ; Input: NODATA - Set to 1 initially
+2 ; Output: NODATE - Set to 1 if at least one Insurance Company
+3 ; with data found
+4 ;N CVLMRC,CVLPRT,CVSWT,IBC,IBCVLT,IBI,IBP,IBPAG,IBQUIT,NEWIC,POSWT,%
+5 ;IB*827/DTG move new of IBQUIT to EN
NEW CVLMRC,CVLPRT,CVSWT,IBC,IBCVLT,IBI,IBP,IBPAG,NEWIC,POSWT,%
+6 ;
+7 ;IB*827/DTG new var for line feeds and page breaks
NEW IBOINS
SET IBOINS=""
+8 ;
+9 ;IB*827/DTG new counter for pause
NEW IBOLK
SET IBOLK=0
+10 SET (IBI,IBQUIT,IBPAG,CVLPRT,POSWT)=0
SET IBCVLT=""
+11 FOR
SET IBI=$ORDER(^TMP($JOB,"PR",IBI))
if ('IBI!IBQUIT)
QUIT
Begin DoDot:1
+12 SET IBC=$GET(^TMP($JOB,"PR",IBI))
SET POSWT=+$PIECE(IBC,U,1)
+13 IF $DATA(^TMP($JOB,"PR",IBI))=1
QUIT
+14 SET NODATA=0
+15 ;D COMP D Q:IBQUIT
+16 ;IB*827/DTG increase checks for line pause
DO P0
if IBQUIT
QUIT
Begin DoDot:2
+17 SET IBP=0
+18 ;IB*TBD/XXX value for pause
SET IBOLK=0
SET CVLPRT=0
+19 ; plan
+20 ;F S IBP=$O(^TMP($J,"PR",IBI,IBP)) Q:'IBP D Q:IBQUIT
+21 ;IB*827/DTG value for pause
FOR
SET IBP=$ORDER(^TMP($JOB,"PR",IBI,IBP))
if ('IBP&('IBOLK))
DO P1
if 'IBP
QUIT
Begin DoDot:3
+22 SET IBPD=$GET(^TMP($JOB,"PR",IBI,IBP))
+23 ;I $Y>(IOSL-5) D PAUSE Q:IBQUIT D COMP
+24 ;IB*827/DTG value for pause
IF $Y>(MAXCNT-($SELECT('NEWIC:5,1:1)))
DO PAUSE
if IBQUIT
QUIT
SET CVLPRT=0
SET IBOLK=1
SET IBOINS=0
DO COMP
SET IBOINS=1
+25 SET CVSWT=1
DO PLAN
+26 ; coverage
+27 SET IBCVLT=""
+28 FOR
SET IBCVLT=$ORDER(^TMP($JOB,"PR",IBI,IBP,IBCVLT))
if IBCVLT=""
QUIT
Begin DoDot:4
+29 SET CVLMRC=$GET(^TMP($JOB,"PR",IBI,IBP,IBCVLT))
+30 ;IB*827/DTG value for pause
IF $Y>(MAXCNT-($SELECT(+CVSWT:4,1:0)))
DO PAUSE
if IBQUIT
QUIT
SET CVLPRT=0
SET IBOLK=1
SET IBOINS=0
DO COMP
DO PLAN
if 'CVSWT
DO CVLMHD
SET IBOINS=1
+31 IF +CVSWT
DO CVLMHD
SET CVSWT=0
+32 ;IB*827/DTG correct so that lines are in the capture buffer
+33 ;W !?4,$P(CVLMRC,U,1),?30,$P(CVLMRC,U,2),?50,$P(CVLMRC,U,3)
+34 WRITE ?4,$PIECE(CVLMRC,U,1),?30,$PIECE(CVLMRC,U,2),?50,$PIECE(CVLMRC,U,3),!
+35 ;IB*827/DTG value for pause
IF $Y>MAXCNT
DO PAUSE
if IBQUIT
QUIT
SET CVLPRT=0
SET IBOLK=1
SET IBOINS=0
DO COMP
DO PLAN
DO CVLMHD
SET IBOINS=1
+36 SET CVLPRT=1
End DoDot:4
if IBQUIT
QUIT
End DoDot:3
if IBQUIT
QUIT
End DoDot:2
if IBQUIT
QUIT
End DoDot:1
+37 ;
+38 ;IB*827/DTG move new of IBQUIT to EN
+39 ;K IBC,IBCVLM,IBI,IBJJ,IBQUIT,IBP,IBPAG,IBPD,IBS,IBSD
+40 KILL IBC,IBCVLM,IBI,IBJJ,IBP,IBPAG,IBPD,IBS,IBSD
+41 QUIT
+42 ;
COMP ; Print Company header
+1 ;IB*827/DTG for page breaks.
IF IBOINS=1
WRITE !!
DO COMPS
SET NEWIC=1
QUIT
+2 ; Input: NODATA - 1 if no data was found
+3 IF CRT!(IBPAG)
WRITE @IOF
+4 SET IBPAG=IBPAG+1
+5 ;IB*TBD/XXX fix extra line feed at top of display
+6 ;W !,"INSURANCE PLANS MISSING DATA"
+7 IF 'CRT
WRITE !
+8 WRITE "INSURANCE PLANS MISSING DATA"
+9 ;IB*827/DTG correct so that lines are in the capture buffer
+10 ;W ?80,IBHDT,?110,"Page: ",IBPAG
+11 ;W !,$G(SUBHD),!
+12 WRITE ?80,IBHDT,?110,"Page: ",IBPAG,!
+13 WRITE $GET(SUBHD),!!
+14 IF +$GET(NODATA)
Begin DoDot:1
+15 WRITE !!!,"--- No Data To Report ---",!
End DoDot:1
QUIT
+16 ;
+17 ;IB*827/DTG moved co info for page breaks.
DO COMPS
+18 ; - sub-header
+19 ;W !?1,$P(IBC,U,2)_" "_$P(IBC,U,3)_" "_$P(IBC,U,4)
+20 ;I +POSWT W ?90,"PRESCRIPTION ONLY"
+21 SET NEWIC=1
+22 QUIT
+23 ;
COMPS ; Print Company SUB header
+1 ;
+2 ; - sub-header
+3 ;IB*827/DTG correct so that lines are in the capture buffer
+4 WRITE ?1,$PIECE(IBC,U,2)_" "_$PIECE(IBC,U,3)_" "_$PIECE(IBC,U,4)
+5 IF +POSWT
WRITE ?90,"PRESCRIPTION ONLY"
+6 WRITE !
+7 QUIT
+8 ;
PLAN ; Print plan information.
+1 IF CVLPRT
WRITE !
SET CVLPRT=0
+2 IF +NEWIC
Begin DoDot:1
+3 ;W !!?2,"GROUP NUMBER",?20,"GROUP NAME",?46,"TYPE OF PLAN",?62,"ELEC PLAN",?78,"FTF"
+4 ;IB*827/DTG line feeds
WRITE !?2,"GROUP NUMBER",?20,"GROUP NAME",?46,"TYPE OF PLAN",?62,"ELEC PLAN",?78,"FTF"
+5 ;W:+$G(POSWT) ?98,"BIN",?109,"PCN"
+6 if +$GET(POSWT)
WRITE ?98,"BIN",?109,"PCN"
WRITE !
+7 ;W !?2,"------------",?20,"----------",?46,"------------",?62,"---------",?78,"---"
+8 ;IB*827/DTG line feeds
WRITE ?2,"------------",?20,"----------",?46,"------------",?62,"---------",?78,"---"
+9 ;W:+$G(POSWT) ?98,"---",?109,"---"
+10 ;IB*827/DTG line feeds
if +$GET(POSWT)
WRITE ?98,"---",?109,"---"
WRITE !
End DoDot:1
+11 ;W !?2,$P(IBPD,U,2),?20,$E($P(IBPD,U,3),1,25),?46,$E($P(IBPD,U,4),1,15)
+12 ;IB*827/DTG line feeds
WRITE ?2,$PIECE(IBPD,U,2),?20,$EXTRACT($PIECE(IBPD,U,3),1,25),?46,$EXTRACT($PIECE(IBPD,U,4),1,15)
+13 WRITE ?62,$EXTRACT($PIECE(IBPD,U,5),1,15),?78,$PIECE(IBPD,U,6)
+14 if +$GET(POSWT)
WRITE ?98,$PIECE(IBPD,U,7),?109,$PIECE(IBPD,U,8)
+15 ;IB*827/DTG correct so that lines are in the capture buffer
WRITE !
+16 ;
+17 SET NEWIC=0
+18 QUIT
+19 ;
CVLMHD ; Print Coverage Limit sub-header
+1 ;W !!?4,"Coverage",?30,"Effective Date",?50,"Covered?"
+2 ;IB*827/DTG line feeds
WRITE !?4,"Coverage",?30,"Effective Date",?50,"Covered?",!
+3 ;W !?4,"--------",?30,"--------------",?50,"--------"
+4 ;IB*827/DTG line feeds
WRITE ?4,"--------",?30,"--------------",?50,"--------"
+5 ;IB*827/DTG correct so that lines are in the capture buffer
WRITE !
+6 QUIT
+7 ;
P0 ; IB*827/DTG IBI check before pause
+1 ;
+2 NEW IBAC
SET IBAC=0
+3 IF IBOINS=1&(IBOLK=1)
SET IBAC=1
+4 IF $Y>(MAXCNT-7)
SET IBOINS=0
+5 IF IBAC&('IBOINS)
DO PAUSE
if IBQUIT
QUIT
+6 DO COMP
+7 SET IBOINS=1
+8 QUIT
+9 ;
P1 ; IB*827/DTG IBP check before pause
+1 IF $Y>(MAXCNT-($SELECT('NEWIC:5,1:1)))
DO PAUSE
+2 QUIT
+3 ;
PAUSE ; Pause for screen output.
+1 ;IB*TBD/XXX correct newing
NEW IBJJ,DIR,DIRUT,DTOUT,DUOUT
+2 ;Q:$E(IOST,1,2)'["C-"
+3 ;F IBJJ=$Y:1:(IOSL-7) W !
+4 ;IB*827/DTG don't allow to many line feeds
FOR IBJJ=$Y:1:IBXTFEED
WRITE !
+5 ;IB*827/DTG need linefeeds if printed
if 'CRT
QUIT
+6 SET DIR(0)="E"
DO ^DIR
KILL DIR
+7 IF $DATA(DIRUT)!($DATA(DUOUT))
SET IBQUIT=1
KILL DIRUT,DTOUT,DUOUT
+8 QUIT
