Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCNSM5

IBCNSM5.m

Go to the documentation of this file. 
  1. IBCNSM5	;ALB/NLR - INSURANCE MANAGEMENT WORKSHEET ; 23-JUL-93
  1. 	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
  1. 	;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. 	;
  1. %	G EN^IBCNSM
  1. 	;
  1. WPPC	; -- print insurance management worksheet, insurance coverage
  1. 	;
  1. 	N IBCAB,IBPIB1,IBPAG,IBQUIT,IBW
  1. 	S IBPIB1=1,IBW=1
  1. 	D GETEN1 I ('($G(IBW)))!(IBYR<(DT-10000)&($G(IBLINE)))!($D(DIRUT)) G WPPCQ
  1. 	D DEV
  1. 	I $G(IBQUIT) G WPPCQ
  1. DQ	;
  1. 	S IBPAG=0,IBHDT=$$HTE^XLFDT($H,1)
  1. 	D PR
  1. 	D:IBCY GETEN2
  1. 	D:IBYR&IBCY PR
  1. 	I $E(IOST,1,2)="C-",IBPAG D PAUSE^VALM1 I $D(DIRUT) S IBQUIT=1 Q
  1. WPPCQ	I $D(ZTQUEUED) S ZTREQ="@" Q
  1. 	D ^%ZISC
  1. 	K IBCPOL,IBYR,IBPIB1,IBW
  1. 	Q 
  1. PR	; -- set variables needed for file navigation, print insurance worksheet or coverage
  1. 	;
  1. 	D SETVAR
  1. 	D PRINT
  1. PRQ	Q
  1. 	;
  1. GETEN1	; -- find IEN of most recent policy
  1. 	;
  1. 	;N IBCDFND,IBCDFND1,IBCDFND2
  1. 	;I $G(IBYR)="" S IBYR=DT
  1. 	I '$G(IBCPOL) S IBCPOL=$P($G(^IBA(355.4,$G(DA),0)),"^",2)
  1. 	I 'IBCPOL G GETEN1Q
  1. 	S IBYR=$O(^IBA(355.4,"APY",IBCPOL,-(DT+.0001))) I IBYR S:IBYR<0 IBYR=-IBYR
  1. 	I ('IBYR),'IBLINE D ASK I ($D(DIRUT))!('($G(IBW))) G GETEN1Q
  1. 	I $G(IBLINE)&(('IBYR)!(IBYR<(DT-10000))) S IBYR=DT
  1. 	S IBCAB="" S IBCAB=$O(^IBA(355.4,"APY",IBCPOL,-IBYR,IBCAB))
  1. 	;W !!,"DATE OF PREVIOUS ENTRY IS "_$$DAT1^IBOUTL(IBYR),!! H 3
  1. 	;I IBYR<(DT-10000),IBLINE S IBYR=DT
  1. 	;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
  1. GETEN1Q	Q
  1. 	;
  1. SETVAR	; -- set variables needed for file navigation
  1. 	;
  1. 	S IBCDFND=$G(^DPT(DFN,.312,$P(IBPPOL,"^",4),0)),IBCNS=+IBCDFND
  1. 	S IBCDFND1=$G(^DPT(DFN,.312,$P(IBPPOL,"^",4),1))
  1. 	S IBCDFND2=$G(^DPT(DFN,.312,$P(IBPPOL,"^",4),2))
  1. 	S IBCDFNDA=$G(^DIC(36,+IBCDFND,.11))
  1. 	S IBCDFNDB=$G(^DIC(36,+IBCDFND,.13))
  1. 	S IBCPOL=+$P(IBCDFND,"^",18),IBCNS=+IBCDFND,IBCDFN=$P(IBPPOL,"^",4)
  1. 	S IBCPOLD=$G(^IBA(355.3,+$P(IBCDFND,"^",18),0))
  1. 	S FILE="^DPT("_DFN_",.312,"
  1. 	S IBCBU=$O(^IBA(355.5,"APPY",DFN,IBCPOL,-IBYR,IBCDFN,0))
  1. 	S IBCBUD=$G(^IBA(355.5,+IBCBU,0))
  1. 	S IBCBUD1=$G(^IBA(355.5,+IBCBU,1))
  1. 	S IBCGN=$$GRP^IBCNS(IBCPOL)
  1. 	S IBPAT=1
  1. 	S IBCABD=$G(^IBA(355.4,+IBCAB,0))
  1. 	S IBCABD2=$G(^IBA(355.4,+IBCAB,2))
  1. 	S IBCABD3=$G(^IBA(355.4,+IBCAB,3))
  1. 	S IBCABD4=$G(^IBA(355.4,+IBCAB,4))
  1. 	S IBCABD5=$G(^IBA(355.4,+IBCAB,5))
  1. 	Q
  1. 	;
  1. DEV	; -- ask for device
  1. 	;
  1. 	W !!,"*** You will need a 132 column printer for this report. ***",!
  1. 	S %ZIS="QM" D ^%ZIS I POP S IBQUIT=1 G R1Q
  1. 	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
  1. 	I $E(IOST,1,2)="C-" D FULL^VALM1
  1. 	U IO
  1. R1Q	Q
  1. 	;
  1. PRINT	; -- print insurance management worksheet/insurance coverage
  1. 	;
  1. 	D PID^VADPT
  1. 	D HDR
  1. 	D BL1^IBCNSM6,BL2^IBCNSM7,BL3^IBCNSM8,BL4^IBCNSM8,BL5^IBCNSM9,BL6^IBCNSM9,BL7^IBCNSM9
  1. 	Q
  1. 	;
  1. HDR	; -- print header
  1. 	;
  1. 	I $E(IOST,1,2)["C-",IBPAG D PAUSE^VALM1 I $D(DIRUT) S IBQUIT=1 Q
  1. 	W:$E(IOST,1,2)["C-"!($G(IBPAG)) @IOF
  1. 	S IBPAG=$G(IBPAG)+1
  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
  1. 	W !,$TR($J(" ",IOM)," ","_")
  1. 	D DEM^VADPT
  1. 	W !!,VADM(1),?34,"PT ID:  "_VA("PID"),?79,"DOB:  "_$P(VADM(3),"^",2)
  1. 	W !,$E($P($G(^DIC(36,+IBCDFND,0)),"^"),1,28),?31," GROUP #:  ",$$DOL^IBCNSM6(355.3,.04,$P(IBCPOLD,"^",4),$G(IBLINE))
  1. 	W ?74,"For YEAR:  "_$S($G(IBCAB):$$DAT1^IBOUTL(IBYR),1:"______________")
  1. 	W !?30,"Ins. Type:  ",$$DOL^IBCNSM6(355.1,.01,$P($G(^IBE(355.1,+$P(IBCPOLD,"^",9),0)),"^"),$G(IBLINE))
  1. 	Q
  1. 	;
  1. GETEN2	; -- get IEN of next-to-most-recent entry (Print Coverage)
  1. 	;
  1. 	S IBYR=$O(^IBA(355.4,"APY",IBCPOL,-IBYR)) I 'IBYR G PR1Q
  1. 	S:IBYR<0 IBYR=-IBYR
  1. 	S IBCAB="" S IBCAB=$O(^IBA(355.4,"APY",IBCPOL,-IBYR,IBCAB))
  1. 	S IBPIB1=0
  1. PR1Q	Q
  1. 	;
  1. ASK	; -- if Print Coverage and no benefit years for selected policy, ask if user wants worksheet 
  1. 	;
  1. 	W !
  1. 	S DIR(0)="YO",DIR("A")="No Benefit Years on File.  Do you want to fill out a worksheet",DIR("B")="No"
  1. 	W !
  1. 	D ^DIR K DIR I $D(DIRUT) S IBQUIT=1 G ASKQ
  1. 	I Y S IBW=1,IBLINE=1,IBCY=0 G ASKQ
  1. 	S IBW=0 D PAUSE^VALM1
  1. ASKQ	;
  1. 	Q