IBCNSM5 ;ALB/NLR - INSURANCE MANAGEMENT WORKSHEET ; 23-JUL-93
;;2.0;INTEGRATED BILLING;**28,497,516**;21-MAR-94;Build 123
;;Per VA Directive 6402, this routine should not be modified.
;
% G EN^IBCNSM
;
WPPC ; -- print insurance management worksheet, insurance coverage
;
I '$G(IBCPOL) D G WPPCQ
.D FULL^VALM1
.W !!,"There is no plan associated with this policy!"
.W !!,"Please use the action 'Change Plan Info', which will create a plan"
.W !,"for the policy."
.N DIR,DTOUT,DUOUT,DIROUT S DIR(0)="E" W ! D ^DIR
;
N IBCAB,IBPIB1,IBPAG,IBQUIT,IBW
S IBPIB1=1,IBW=1
D GETEN1 I ('($G(IBW)))!(IBYR<(DT-10000)&($G(IBLINE)))!($D(DIRUT)) G WPPCQ
D DEV
I $G(IBQUIT) G WPPCQ
DQ ;
S IBPAG=0,IBHDT=$$HTE^XLFDT($H,1)
D PR
D:IBCY GETEN2
D:IBYR&IBCY PR
I $E(IOST,1,2)="C-",IBPAG D PAUSE^VALM1 I $D(DIRUT) S IBQUIT=1 Q
WPPCQ I $D(ZTQUEUED) S ZTREQ="@" Q
D ^%ZISC
K IBCPOL,IBYR,IBPIB1,IBW
Q
PR ; -- set variables needed for file navigation, print insurance worksheet or coverage
;
D SETVAR
D PRINT
PRQ Q
;
GETEN1 ; -- find IEN of most recent policy
;
;N IBCDFND,IBCDFND1,IBCDFND2
;I $G(IBYR)="" S IBYR=DT
;I '$G(IBCPOL) S IBCPOL=$P($G(^IBA(355.4,$G(DA),0)),"^",2)
;I 'IBCPOL G GETEN1Q
S IBYR=$O(^IBA(355.4,"APY",IBCPOL,-(DT+.0001))) I IBYR S:IBYR<0 IBYR=-IBYR
I ('IBYR),'IBLINE D ASK I ($D(DIRUT))!('($G(IBW))) G GETEN1Q
I $G(IBLINE)&(('IBYR)!(IBYR<(DT-10000))) S IBYR=DT
S IBCAB="" S IBCAB=$O(^IBA(355.4,"APY",IBCPOL,-IBYR,IBCAB))
;W !!,"DATE OF PREVIOUS ENTRY IS "_$$DAT1^IBOUTL(IBYR),!! H 3
;I IBYR<(DT-10000),IBLINE S IBYR=DT
;I IBYR<(DT-10000),IBLINE W !!,"MOST RECENT ENTRY IS "_$$DAT1^IBOUTL(IBYR)_". ENTRY CANNOT BE MORE THAN A YEAR OLD.",!!,"YOU MAY PRINT ENTRY UNDER 'PC'.",!! H 4
GETEN1Q Q
;
SETVAR ; -- set variables needed for file navigation
;
;IB*2.0*516/TAZ - Use HIPAA compliant fields
;S IBCDFND=$G(^DPT(DFN,.312,$P(IBPPOL,"^",4),0)),IBCNS=+IBCDFND ; 516 - baa
S IBCDFND=$$ZND^IBCNS1(DFN,$P(IBPPOL,"^",4)),IBCNS=+IBCDFND ; 516 - baa
S IBCDFND1=$G(^DPT(DFN,.312,$P(IBPPOL,"^",4),1))
S IBCDFND2=$G(^DPT(DFN,.312,$P(IBPPOL,"^",4),2))
S IBCDFNDA=$G(^DIC(36,+IBCDFND,.11))
S IBCDFNDB=$G(^DIC(36,+IBCDFND,.13))
S IBCPOL=+$P(IBCDFND,"^",18),IBCNS=+IBCDFND,IBCDFN=$P(IBPPOL,"^",4)
;IB*2.0*516/TAZ - replace Group Number and Group Name with HIPAA compliant fields
S IBCPOLD=$G(^IBA(355.3,IBCPOL,0)),$P(IBCPOLD,U,3)=$$GET1^DIQ(355.3,IBCPOL_",",2.01),$P(IBCPOLD,U,4)=$$GET1^DIQ(355.3,IBCPOL_",",2.02)
S FILE="^DPT("_DFN_",.312,"
S IBCBU=$O(^IBA(355.5,"APPY",DFN,IBCPOL,-IBYR,IBCDFN,0))
S IBCBUD=$G(^IBA(355.5,+IBCBU,0))
S IBCBUD1=$G(^IBA(355.5,+IBCBU,1))
S IBCGN=$$GRP^IBCNS(IBCPOL)
S IBPAT=1
S IBCABD=$G(^IBA(355.4,+IBCAB,0))
S IBCABD2=$G(^IBA(355.4,+IBCAB,2))
S IBCABD3=$G(^IBA(355.4,+IBCAB,3))
S IBCABD4=$G(^IBA(355.4,+IBCAB,4))
S IBCABD5=$G(^IBA(355.4,+IBCAB,5))
Q
;
DEV ; -- ask for device
;
W !!,"*** You will need a 132 column printer for this report. ***",!
S %ZIS="QM" D ^%ZIS I POP S IBQUIT=1 G R1Q
I $D(IO("Q")) K IO("Q") S IBQUIT=1,ZTRTN="DQ^IBCNSM5",ZTSAVE("IB*")="",ZTSAVE("DFN")="",ZTDESC="INSURANCE MANAGEMENT WORKSHEET" D ^%ZTLOAD K ZTSK D HOME^%ZIS Q
I $E(IOST,1,2)="C-" D FULL^VALM1
U IO
R1Q Q
;
PRINT ; -- print insurance management worksheet/insurance coverage
;
D PID^VADPT
D HDR
D BL1^IBCNSM6,BL2^IBCNSM7,BL3^IBCNSM8,BL4^IBCNSM8,BL5^IBCNSM9,BL6^IBCNSM9,BL7^IBCNSM9
Q
;
HDR ; -- print header
;
I $E(IOST,1,2)["C-",IBPAG D PAUSE^VALM1 I $D(DIRUT) S IBQUIT=1 Q
W:$E(IOST,1,2)["C-"!($G(IBPAG)) @IOF
S IBPAG=$G(IBPAG)+1
W !,$S($G(IBLINE):"INSURANCE MANAGEMENT WORKSHEET",1:"INSURANCE COVERAGE FOR "_$S($G(IBPIB1):"CURRENT ENTRY",1:"NEXT-MOST-CURRENT ENTRY")),?(IOM-30),IBHDT," PAGE ",IBPAG
W !,$TR($J(" ",IOM)," ","_")
D DEM^VADPT
W !!,VADM(1),?34,"PT ID: "_VA("PID"),?79,"DOB: "_$P(VADM(3),"^",2)
W !,$E($P($G(^DIC(36,+IBCDFND,0)),"^"),1,28),?31," GROUP #: ",$$DOL^IBCNSM6(355.3,2.02,$P(IBCPOLD,"^",4),$G(IBLINE)) ;WCJ;IB*2.0*497 changed .04 to 2.02 for new Group# field
W ?74,"For YEAR: "_$S($G(IBCAB):$$DAT1^IBOUTL(IBYR),1:"______________")
W !?30,"Ins. Type: ",$$DOL^IBCNSM6(355.1,.01,$P($G(^IBE(355.1,+$P(IBCPOLD,"^",9),0)),"^"),$G(IBLINE))
Q
;
GETEN2 ; -- get IEN of next-to-most-recent entry (Print Coverage)
;
S IBYR=$O(^IBA(355.4,"APY",IBCPOL,-IBYR)) I 'IBYR G PR1Q
S:IBYR<0 IBYR=-IBYR
S IBCAB="" S IBCAB=$O(^IBA(355.4,"APY",IBCPOL,-IBYR,IBCAB))
S IBPIB1=0
PR1Q Q
;
ASK ; -- if Print Coverage and no benefit years for selected policy, ask if user wants worksheet
;
W !
S DIR(0)="YO",DIR("A")="No Benefit Years on File. Do you want to fill out a worksheet",DIR("B")="No"
W !
D ^DIR K DIR I $D(DIRUT) S IBQUIT=1 G ASKQ
I Y S IBW=1,IBLINE=1,IBCY=0 G ASKQ
S IBW=0 D PAUSE^VALM1
ASKQ ;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSM5 4843 printed Dec 13, 2024@02:17:31 Page 2
IBCNSM5 ;ALB/NLR - INSURANCE MANAGEMENT WORKSHEET ; 23-JUL-93
+1 ;;2.0;INTEGRATED BILLING;**28,497,516**;21-MAR-94;Build 123
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
% GOTO EN^IBCNSM
+1 ;
WPPC ; -- print insurance management worksheet, insurance coverage
+1 ;
+2 IF '$GET(IBCPOL)
Begin DoDot:1
+3 DO FULL^VALM1
+4 WRITE !!,"There is no plan associated with this policy!"
+5 WRITE !!,"Please use the action 'Change Plan Info', which will create a plan"
+6 WRITE !,"for the policy."
+7 NEW DIR,DTOUT,DUOUT,DIROUT
SET DIR(0)="E"
WRITE !
DO ^DIR
End DoDot:1
GOTO WPPCQ
+8 ;
+9 NEW IBCAB,IBPIB1,IBPAG,IBQUIT,IBW
+10 SET IBPIB1=1
SET IBW=1
+11 DO GETEN1
IF ('($GET(IBW)))!(IBYR<(DT-10000)&($GET(IBLINE)))!($DATA(DIRUT))
GOTO WPPCQ
+12 DO DEV
+13 IF $GET(IBQUIT)
GOTO WPPCQ
DQ ;
+1 SET IBPAG=0
SET IBHDT=$$HTE^XLFDT($HOROLOG,1)
+2 DO PR
+3 if IBCY
DO GETEN2
+4 if IBYR&IBCY
DO PR
+5 IF $EXTRACT(IOST,1,2)="C-"
IF IBPAG
DO PAUSE^VALM1
IF $DATA(DIRUT)
SET IBQUIT=1
QUIT
WPPCQ IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+1 DO ^%ZISC
+2 KILL IBCPOL,IBYR,IBPIB1,IBW
+3 QUIT
PR ; -- set variables needed for file navigation, print insurance worksheet or coverage
+1 ;
+2 DO SETVAR
+3 DO PRINT
PRQ QUIT
+1 ;
GETEN1 ; -- find IEN of most recent policy
+1 ;
+2 ;N IBCDFND,IBCDFND1,IBCDFND2
+3 ;I $G(IBYR)="" S IBYR=DT
+4 ;I '$G(IBCPOL) S IBCPOL=$P($G(^IBA(355.4,$G(DA),0)),"^",2)
+5 ;I 'IBCPOL G GETEN1Q
+6 SET IBYR=$ORDER(^IBA(355.4,"APY",IBCPOL,-(DT+.0001)))
IF IBYR
if IBYR<0
SET IBYR=-IBYR
+7 IF ('IBYR)
IF 'IBLINE
DO ASK
IF ($DATA(DIRUT))!('($GET(IBW)))
GOTO GETEN1Q
+8 IF $GET(IBLINE)&(('IBYR)!(IBYR<(DT-10000)))
SET IBYR=DT
+9 SET IBCAB=""
SET IBCAB=$ORDER(^IBA(355.4,"APY",IBCPOL,-IBYR,IBCAB))
+10 ;W !!,"DATE OF PREVIOUS ENTRY IS "_$$DAT1^IBOUTL(IBYR),!! H 3
+11 ;I IBYR<(DT-10000),IBLINE S IBYR=DT
+12 ;I IBYR<(DT-10000),IBLINE W !!,"MOST RECENT ENTRY IS "_$$DAT1^IBOUTL(IBYR)_". ENTRY CANNOT BE MORE THAN A YEAR OLD.",!!,"YOU MAY PRINT ENTRY UNDER 'PC'.",!! H 4
GETEN1Q QUIT
+1 ;
SETVAR ; -- set variables needed for file navigation
+1 ;
+2 ;IB*2.0*516/TAZ - Use HIPAA compliant fields
+3 ;S IBCDFND=$G(^DPT(DFN,.312,$P(IBPPOL,"^",4),0)),IBCNS=+IBCDFND ; 516 - baa
+4 ; 516 - baa
SET IBCDFND=$$ZND^IBCNS1(DFN,$PIECE(IBPPOL,"^",4))
SET IBCNS=+IBCDFND
+5 SET IBCDFND1=$GET(^DPT(DFN,.312,$PIECE(IBPPOL,"^",4),1))
+6 SET IBCDFND2=$GET(^DPT(DFN,.312,$PIECE(IBPPOL,"^",4),2))
+7 SET IBCDFNDA=$GET(^DIC(36,+IBCDFND,.11))
+8 SET IBCDFNDB=$GET(^DIC(36,+IBCDFND,.13))
+9 SET IBCPOL=+$PIECE(IBCDFND,"^",18)
SET IBCNS=+IBCDFND
SET IBCDFN=$PIECE(IBPPOL,"^",4)
+10 ;IB*2.0*516/TAZ - replace Group Number and Group Name with HIPAA compliant fields
+11 SET IBCPOLD=$GET(^IBA(355.3,IBCPOL,0))
SET $PIECE(IBCPOLD,U,3)=$$GET1^DIQ(355.3,IBCPOL_",",2.01)
SET $PIECE(IBCPOLD,U,4)=$$GET1^DIQ(355.3,IBCPOL_",",2.02)
+12 SET FILE="^DPT("_DFN_",.312,"
+13 SET IBCBU=$ORDER(^IBA(355.5,"APPY",DFN,IBCPOL,-IBYR,IBCDFN,0))
+14 SET IBCBUD=$GET(^IBA(355.5,+IBCBU,0))
+15 SET IBCBUD1=$GET(^IBA(355.5,+IBCBU,1))
+16 SET IBCGN=$$GRP^IBCNS(IBCPOL)
+17 SET IBPAT=1
+18 SET IBCABD=$GET(^IBA(355.4,+IBCAB,0))
+19 SET IBCABD2=$GET(^IBA(355.4,+IBCAB,2))
+20 SET IBCABD3=$GET(^IBA(355.4,+IBCAB,3))
+21 SET IBCABD4=$GET(^IBA(355.4,+IBCAB,4))
+22 SET IBCABD5=$GET(^IBA(355.4,+IBCAB,5))
+23 QUIT
+24 ;
DEV ; -- ask for device
+1 ;
+2 WRITE !!,"*** You will need a 132 column printer for this report. ***",!
+3 SET %ZIS="QM"
DO ^%ZIS
IF POP
SET IBQUIT=1
GOTO R1Q
+4 IF $DATA(IO("Q"))
KILL IO("Q")
SET IBQUIT=1
SET ZTRTN="DQ^IBCNSM5"
SET ZTSAVE("IB*")=""
SET ZTSAVE("DFN")=""
SET ZTDESC="INSURANCE MANAGEMENT WORKSHEET"
DO ^%ZTLOAD
KILL ZTSK
DO HOME^%ZIS
QUIT
+5 IF $EXTRACT(IOST,1,2)="C-"
DO FULL^VALM1
+6 USE IO
R1Q QUIT
+1 ;
PRINT ; -- print insurance management worksheet/insurance coverage
+1 ;
+2 DO PID^VADPT
+3 DO HDR
+4 DO BL1^IBCNSM6
DO BL2^IBCNSM7
DO BL3^IBCNSM8
DO BL4^IBCNSM8
DO BL5^IBCNSM9
DO BL6^IBCNSM9
DO BL7^IBCNSM9
+5 QUIT
+6 ;
HDR ; -- print header
+1 ;
+2 IF $EXTRACT(IOST,1,2)["C-"
IF IBPAG
DO PAUSE^VALM1
IF $DATA(DIRUT)
SET IBQUIT=1
QUIT
+3 if $EXTRACT(IOST,1,2)["C-"!($GET(IBPAG))
WRITE @IOF
+4 SET IBPAG=$GET(IBPAG)+1
+5 WRITE !,$SELECT($GET(IBLINE):"INSURANCE MANAGEMENT WORKSHEET",1:"INSURANCE COVERAGE FOR "_$SELECT($GET(IBPIB1):"CURRENT ENTRY",1:"NEXT-MOST-CURRENT ENTRY")),?(IOM-30),IBHDT," PAGE ",IBPAG
+6 WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","_")
+7 DO DEM^VADPT
+8 WRITE !!,VADM(1),?34,"PT ID: "_VA("PID"),?79,"DOB: "_$PIECE(VADM(3),"^",2)
+9 ;WCJ;IB*2.0*497 changed .04 to 2.02 for new Group# field
WRITE !,$EXTRACT($PIECE($GET(^DIC(36,+IBCDFND,0)),"^"),1,28),?31," GROUP #: ",$$DOL^IBCNSM6(355.3,2.02,$PIECE(IBCPOLD,"^",4),$GET(IBLINE))
+10 WRITE ?74,"For YEAR: "_$SELECT($GET(IBCAB):$$DAT1^IBOUTL(IBYR),1:"______________")
+11 WRITE !?30,"Ins. Type: ",$$DOL^IBCNSM6(355.1,.01,$PIECE($GET(^IBE(355.1,+$PIECE(IBCPOLD,"^",9),0)),"^"),$GET(IBLINE))
+12 QUIT
+13 ;
GETEN2 ; -- get IEN of next-to-most-recent entry (Print Coverage)
+1 ;
+2 SET IBYR=$ORDER(^IBA(355.4,"APY",IBCPOL,-IBYR))
IF 'IBYR
GOTO PR1Q
+3 if IBYR<0
SET IBYR=-IBYR
+4 SET IBCAB=""
SET IBCAB=$ORDER(^IBA(355.4,"APY",IBCPOL,-IBYR,IBCAB))
+5 SET IBPIB1=0
PR1Q QUIT
+1 ;
ASK ; -- if Print Coverage and no benefit years for selected policy, ask if user wants worksheet
+1 ;
+2 WRITE !
+3 SET DIR(0)="YO"
SET DIR("A")="No Benefit Years on File. Do you want to fill out a worksheet"
SET DIR("B")="No"
+4 WRITE !
+5 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET IBQUIT=1
GOTO ASKQ
+6 IF Y
SET IBW=1
SET IBLINE=1
SET IBCY=0
GOTO ASKQ
+7 SET IBW=0
DO PAUSE^VALM1
ASKQ ;
+1 QUIT
