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.  ;;2.0;INTEGRATED BILLING;**28,497,516**;21-MAR-94;Build 123
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1. % G EN^IBCNSM
  1.  ;
  1. WPPC ; -- print insurance management worksheet, insurance coverage
  1.  ;
  1.  I '$G(IBCPOL) D  G WPPCQ
  1.  .D FULL^VALM1
  1.  .W !!,"There is no plan associated with this policy!"
  1.  .W !!,"Please use the action 'Change Plan Info', which will create a plan"
  1.  .W !,"for the policy."
  1.  .N DIR,DTOUT,DUOUT,DIROUT S DIR(0)="E" W ! D ^DIR
  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.  ;IB*2.0*516/TAZ - Use HIPAA compliant fields
  1.  ;S IBCDFND=$G(^DPT(DFN,.312,$P(IBPPOL,"^",4),0)),IBCNS=+IBCDFND  ; 516 - baa
  1.  S IBCDFND=$$ZND^IBCNS1(DFN,$P(IBPPOL,"^",4)),IBCNS=+IBCDFND  ; 516 - baa
  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.  ;IB*2.0*516/TAZ - replace Group Number and Group Name with HIPAA compliant fields
  1.  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)
  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,2.02,$P(IBCPOLD,"^",4),$G(IBLINE))  ;WCJ;IB*2.0*497 changed .04 to 2.02 for new Group# field
  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