IBCOMA1 ;ALB/CMS/JNM - IDENTIFY ACTIVE POLICIES W/NO EFFECTIVE DATE (CON'T) ; 09-29-2015
;;2.0;INTEGRATED BILLING;**103,516,528,549**;21-MAR-94;Build 54
;;Per VA Directive 6402, this routine should not be modified.
Q
BEG ; Entry to run Active Policies w/no Effective Date Report
; Input variables:
; IBAIB - Required. How to sort
; 1= Patient Name Range 2= Terminal Digit Range
; IBSIN - Required. Include Active Policies with
; 1= Verification Date 2= No Verification Date 3= Both
;
; IBRF - Required. Name or Terminal Digit Range Start value
; IBRL - Required. Name or Terminal Digit Range Go to value
; IBBDT - Optional. Beginning Verification Date Range
; IBEDT - Optional. Ending Verification Date Range
; IBEXCEL - 1 = Excel Format
;
; IB*2*549 - New filter variables
; IBPTYPE - Living/Deceased/Both filter ;
; IBAPPTS - Last Appointment Date Range Start
; IBAPPTE - Last Appointment Date Range End
;
N APPTDATA,CAPPT,CDOD,CGRP,CINS,CLVBY,CLVDAT,CSSN,DFN,IBC,IBC0,IBCDA
N IBCDA0,IBCDA1,IBI,IBPAGE,IBQUIT,IBTD,IBTMP,IBX,IDX,LASTAPPT,LASTVER
N LVDATE,MAXGRP,MAXINS,MAXPT,MAXRPT,MAXVERBY,VA,VADM,VAERR,X,Y
;
; Set starting max field sizes to length of header text
F IDX=1:1:2 S MAXPT(IDX)=12,MAXINS(IDX)=13,MAXGRP(IDX)=9,MAXVERBY(IDX)=5
K ^TMP("IBCOMA",$J)
S IBPAGE=0,IBQUIT=0
;
; Set up filter data for the call to SDAPI^SDAMA301 for IB*2*549
I IBAPPTS>0 S APPTDATA(1)=IBAPPTS_";"_IBAPPTE
S APPTDATA("FLDS")=1 ; Return Appt Date/Time Data
S APPTDATA("MAX")=-1 ; Return Last Appt
K ^TMP($J,"SDAMA301")
;
S IBC=0 F S IBC=$O(^DPT("AB",IBC)) Q:'IBC D
. S IBC0=$G(^DIC(36,IBC,0))
. ;
. ; If company inactive quit
. Q:$P(IBC0,U,1)=""
. Q:$P(IBC0,U,5)=1
. S DFN=0 F S DFN=$O(^DPT("AB",IBC,DFN)) Q:'DFN D
. . K VA,VADM,VAERR
. . D DEM^VADPT
. . ;
. . ; IB*2*549 If Pt. deceased and not showing deceased patients quit
. . I IBPTYPE=1,($G(VADM(6))>0) Q
. . ;
. . ; IB*2*549 If Pt. not deceased and not showing living patients quit
. . I IBPTYPE=2,($G(VADM(6))'>0) Q
. . S VADM(1)=$P($G(VADM(1)),U,1)
. . ;
. . ; I Pt. name out of range quit
. . Q:VADM(1)=""
. . I IBAIB=1,VADM(1)]IBRL Q
. . I IBAIB=1,IBRF]VADM(1) Q
. . ;
. . ; I Terminal Digit out of range quit
. . I IBAIB=2 S IBTD=$$TERMDG^IBCONS2(DFN) S:IBTD="" IBTD="000000000" I (+IBTD>IBRL)!(IBRF>+IBTD) Q
. . ;
. . ; Fix subscript error if terminal digit is null
. . I IBAIB=2,IBTD="" S IBTD=" "
. . ;
. . ; IB*2*549 Filter on last appointment date using ICR# 4433
. . S APPTDATA(4)=DFN
. . I $$SDAPI^SDAMA301(.APPTDATA)>0 D
. . . S LASTAPPT=@$Q(^TMP($J,"SDAMA301"))
. . . K ^TMP($J,"SDAMA301")
. . E S LASTAPPT=0 I IBAPPTS>0 Q ; Filtering on Appt Date but no date in range
. . ;
. . S IBCDA=0 F S IBCDA=$O(^DPT("AB",IBC,DFN,IBCDA)) Q:'IBCDA D
. . . ;IB*2.0*516/TAZ - Retrieve data from HIPAA compliant fields.
. . . ;S IBCDA0=$G(^DPT(DFN,.312,IBCDA,0)) ;516 - baa
. . . S IBCDA0=$$ZND^IBCNS1(DFN,IBCDA) ;516 - baa
. . . ;
. . . ; I Effective Date populated quit
. . . Q:$P(IBCDA0,U,8)
. . . ;
. . . ; I Expiration Date entered and expired quit
. . . I $P(IBCDA0,U,4),$P(IBCDA0,U,4)'>DT Q
. . . ;
. . . ; Sorting by verification date or no date check
. . . S IBCDA1=$G(^DPT(DFN,.312,IBCDA,1))
. . . S LVDATE=+$P($P(IBCDA1,U,3),".",1)
. . . I IBSIN=1,LVDATE=0 Q
. . . I IBSIN=1,IBBDT>0,(LVDATE<IBBDT)!(LVDATE>IBEDT) Q
. . . I IBSIN=2,LVDATE>0 Q
. . . I IBSIN=3,LVDATE>0,IBBDT>0,(LVDATE<IBBDT)!(LVDATE>IBEDT) Q
. . . ;
. . . ; Set data line for global
. . . ;S IBTMP(1)=PT NAME^SSN^DATE OF DEATH^LAST APPT DATE
. . . ;S IBTMP(2)=INSURANCE NAME
. . . ;S IBTMP(3)=VERIFICATION DATE^LAST VERIFIED BY^GROUP NUMBER
. . . ;
. . . S IBTMP(1)=VADM(1)_U_$E(VADM(2),6,9)_U_$$FMTE^XLFDT($P(VADM(6),U,1),"2ZD")
. . . S IBTMP(1)=IBTMP(1)_U_$$FMTE^XLFDT(LASTAPPT,"2ZD")
. . . S IBTMP(2)=$P(IBC0,U,1)
. . . S LASTVER=$P(IBCDA1,U,4)
. . . I LASTVER'="" S LASTVER=$P($G(^VA(200,LASTVER,0)),U)
. . . S IBTMP(3)=$$FMTE^XLFDT(LVDATE,"2ZD")_U_LASTVER_U_$P(IBCDA0,U,3)
. . . ;
. . . ; Set variable IBI for Verified=1 or Non verified=2
. . . S IBI=$S(+$P(IBCDA1,U,3):1,1:2)
. . . I 'IBEXCEL D
. . . . D SETMAX(VADM(1),.MAXPT,IBI),SETMAX($P(IBC0,U,1),.MAXINS,IBI)
. . . . D SETMAX(LASTVER,.MAXVERBY,IBI),SETMAX($P(IBCDA0,U,3),.MAXGRP,IBI)
. . . ;
. . . ; Set Global array
. . . S ^TMP("IBCOMA",$J,IBI,$S(IBAIB=2:+IBTD,1:VADM(1)),DFN)=IBTMP(1)
. . . S ^TMP("IBCOMA",$J,IBI,$S(IBAIB=2:+IBTD,1:VADM(1)),DFN,IBC)=IBTMP(2)
. . . S ^TMP("IBCOMA",$J,IBI,$S(IBAIB=2:+IBTD,1:VADM(1)),DFN,IBC,IBCDA)=IBTMP(3)
I 'IBEXCEL D CALCCOLS
I '$D(^TMP("IBCOMA",$J)) D G QUEQ
. D HD(1)
. W !!,"** NO RECORDS FOUND **"
. D ASK^IBCOMC2
D WRT
W !!,"** END OF REPORT **",!
;
QUEQ ; Exit clean-UP
W !
D ^%ZISC
K IBAIB,IBAPPTE,IBAPPTS,IBEXCEL,IBPTYPE,IBRF,IBRL,IBSIN,IBTMP,VA,VADM,VAERR,^TMP("IBCOMA",$J)
Q
;
HD(IBA) ; Write Heading
; Input: IBA - 1 - Header for non-verified policies
; 2 - Header for verified policies
; CAPPT(IBA) - Starting Column Position for the 'Last Apt' Column
; CDOD(IBA) - Starting Column Position for the 'DoD' Column
; CGRP(IBA) - Starting Column Position for the 'Group No.' Column
; CINS(IBA) - Starting Column Position for the 'Insurance Co.' Column
; CSSN(IBA) - Starting Column Position for the 'SSN' Column
; CLVDAT(IBA) - Starting Column Position for the 'Last VC' Column
; CLVBY(IBA) - Starting Column Position for the 'VC By' Column
; IBPAGE - Current Page Number
; MAXRPT(IBA) - Maximum number of characters in column header line
; Output: IBPAGE - Updated Page Number
;
; IB*2.0*549 changed include Appoint Date filtering and
; dynamic column width based on actual data sizes
I IBEXCEL D I 1
. D PGHD(0)
. W !!,"Patient Name^SSN^Insurance Co.^Group No.^Last VC^VC By^Last Apt^DoD"
E D
. S IBPAGE=IBPAGE+1
. D PGHD(IBPAGE)
. W !!,"Patient Name",?CSSN(IBA),"SSN",?CINS(IBA),"Insurance Co.",?CGRP(IBA),"Group No."
. I IBA=1 W ?CLVDAT(IBA),"Last VC",?CLVBY(IBA),"VC By"
. W ?CAPPT(IBA),"Last Apt",?CDOD(IBA),"DoD"
. W !
. F IBX=1:1:MAXRPT(IBA) W "="
Q
;
PGHD(IBPAGE) ; Print Report Page Header
; Input: IBPAGE - Current Page Number, 0 if exporting to Excel
; IBAIB - 1 Sorting by Patient Name, 2 - Sorting by Terminal Digit
; IBAPPTE - Internal Appointment Date Range End
; 0 if no Appointment Date Range filter
; IBAPPTS - Internal Appointment Date Range Start
; 0 if no Appointment Date Range filter
; IBBDT - Internal Verification Start date for Verification filter
; Null if no Verification filter
; IBEDT - Internal Verification End date for Verification filter
; Null if no Verification filter
; IBRF - "A" - First Patient Name, otherwise start of range filter
; IBRL - End of range filter
;
N IBHDT
S IBHDT=$$FMTE^XLFDT($$NOW^XLFDT,"Z")
W:IBPAGE @IOF
W:'IBPAGE !!
W "Active Policies with no Effective Date Report "
I 'IBPAGE D
. W " Run On: ",IBHDT
E D
. W ?IOM-34,IBHDT,?IOM-10,"Page: ",IBPAGE
I IBPAGE W !,?5,"Sorted by: "
E W !,?6,"Contains: "
W $S(IBAIB=1:"Patient Name",1:"Terminal Digit")
W " Range: "_$S(IBRF="A":"FIRST",1:IBRF)_" to "_$S(IBRL="zzzzzz":"LAST",1:IBRL)
I IBBDT>0 D
. W !,?7,"Include: Verification Date Range: "_$$FMTE^XLFDT(IBBDT,"Z")
. W " to "_$$FMTE^XLFDT(IBEDT,"Z")
I IBAPPTS>0 D
. W !,?7,"Include: Last Appointment Date Range: "_$$FMTE^XLFDT(IBAPPTS,"Z")
. W " to "_$$FMTE^XLFDT(IBAPPTE,"Z")
W !,?8,"Filter: "_$S(IBPTYPE=1:"Living Patients",IBPTYPE=2:"Deceased Patients",1:"Both Living & Deceased Patients")
W ", "_$S(IBSIN=1:"Verified Policies",IBSIN=2:"Non-Verified Policies",1:"Both Verified & Non-Verified Policies")
Q
;
WRT ; Write data lines
N IBA,IBCDA,IBDA,IBFIRST,IBDFN,IBINS,IBNA,IBPOL,IBPT,X,Y
S IBQUIT=0,IBFIRST=1
S IBA=0 F S IBA=$O(^TMP("IBCOMA",$J,IBA)) Q:('IBA)!(IBQUIT=1) D
. I IBPAGE D ASK^IBCOMC2 I IBQUIT=1 Q
. I IBEXCEL,IBFIRST D
. . D HD(IBA)
. . S IBFIRST=0
. ;
. I 'IBEXCEL D
. . D HD(IBA)
. . W !,$S(IBA=1:"Verified",1:"Non-Verified"),!
. S IBNA="" F S IBNA=$O(^TMP("IBCOMA",$J,IBA,IBNA)) Q:(IBNA="")!(IBQUIT=1) D
. . S IBDFN=0 F S IBDFN=$O(^TMP("IBCOMA",$J,IBA,IBNA,IBDFN)) Q:('IBDFN)!(IBQUIT=1) D
. . . S IBPT=$G(^TMP("IBCOMA",$J,IBA,IBNA,IBDFN))
. . . ;
. . . I 'IBEXCEL,($Y+7)>IOSL D I IBQUIT=1 Q
. . . . D ASK^IBCOMC2 I IBQUIT=1 Q
. . . . D HD(IBA)
. . . ;
. . . S IBDA=0 F S IBDA=$O(^TMP("IBCOMA",$J,IBA,IBNA,IBDFN,IBDA)) Q:('IBDA)!(IBQUIT=1) D
. . . . S IBINS=$G(^TMP("IBCOMA",$J,IBA,IBNA,IBDFN,IBDA))
. . . . ;
. . . . S IBCDA=0 F S IBCDA=$O(^TMP("IBCOMA",$J,IBA,IBNA,IBDFN,IBDA,IBCDA)) Q:('IBCDA)!(IBQUIT=1) D
. . . . . S IBPOL=$G(^TMP("IBCOMA",$J,IBA,IBNA,IBDFN,IBDA,IBCDA))
. . . . . I IBEXCEL D I 1
. . . . . . W !,$P(IBPT,U,1),U,$P(IBPT,U,2),U,$P(IBINS,U,1),U,$P(IBPOL,U,3),U
. . . . . . I $P(IBPOL,U,1)'=0 W $P(IBPOL,U,1)
. . . . . . W U_$P(IBPOL,U,2)_U
. . . . . . W $P(IBPT,U,4),U,$P(IBPT,U,3)
. . . . . E D
. . . . . . W !,$E($P(IBPT,U,1),1,MAXPT(IBA)),?CSSN(IBA),$P(IBPT,U,2),?CINS(IBA)
. . . . . . W $E($P(IBINS,U,1),1,MAXINS(IBA)),?CGRP(IBA),$E($P(IBPOL,U,3),1,MAXGRP(IBA))
. . . . . . I IBA=1 W ?CLVDAT(IBA),$P(IBPOL,U,1),?CLVBY(IBA),$E($P(IBPOL,U,2),1,MAXVERBY(IBA))
. . . . . . W ?CAPPT(IBA),$P(IBPT,U,4),?CDOD(IBA),$P(IBPT,U,3)
Q
;
SETMAX(NAME,MAX,IBI) ; Get max length of data
; Input: NAME - Data to get maximum length for
; MAX(IBI)- Current Max length array
; IBI - Verified or Non-Verified section of the array
; Output MAX(IBI)- Updated Max length array (potentially)
N LEN
S LEN=$L(NAME)
I LEN>MAX(IBI) S MAX(IBI)=LEN
Q
;
CALCCOLS ; Truncates the patient and insurance name field lengths if the total
; field lengths will not fit on the report (132 columns)
; Input: MAXGRP(IBA) - Maximum width of the 'Group No' column for
; verified (IBA=1) and non-verified (IBA=2) policies
; MAXINS(IBA) - Current Maximum width of the 'Insurance Co' column for
; verified (IBA=1) and non-verified (IBA=2) policies
; MAXPT(IBA) - Current Maximum width of the 'Patient Name' column for
; verified (IBA=1) and non-verified (IBA=2) policies
; MAXVERBY(IBA) - Maximum width of the 'VC By' column for
; verified (IBA=1) policies
; Output: MAXINS(IBA) - Updated Maximum width of the 'Insurance Co' column for
; verified (IBA=1) and non-verified (IBA=2) policies
; MAXPT(IBA) - Updated Maximum width of the 'Patient Name' column for
; verified (IBA=1) and non-verified (IBA=2) policies
N DIFF,DIFF2,DIFF3,IDX,MAX
S MAX(1)=89 ; MAX=131 - SSN(4) - 3 Dates(24) - 14 (Spaces between columns)
S MAX(2)=101 ; MAX=131 - SSN(4) - 2 Dates(16) - 10 (Spaces between columns)
F IDX=1:1:2 D
. S DIFF=MAX(IDX)-MAXPT(IDX)-MAXINS(IDX)-MAXGRP(IDX)
. I IDX=1 S DIFF=DIFF-MAXVERBY(IDX)
. I DIFF<0 D
. . S DIFF2=(-DIFF)\2
. . S DIFF3=(-DIFF)-DIFF2
. . S MAXPT(IDX)=MAXPT(IDX)-DIFF2
. . S MAXINS(IDX)=MAXINS(IDX)-DIFF3
. D SETCOLS(IDX)
Q
;
SETCOLS(IDX) ; Sets the column positions based on maximum data sizes
; Input: IDX - 1 - Verified policies section of the report
; 2 - Non-Verified policies section of the report
; MAXGRP(IBA) - Maximum width of the 'Group No' column for
; verified (IBA=1) and non-verified (IBA=2) policies
; MAXINS(IBA) - Maximum width of the 'Insurance Co' column for
; verified (IBA=1) and non-verified (IBA=2) policies
; MAXPT(IBA) - Maximum width of the 'Patient Name' column for
; verified (IBA=1) and non-verified (IBA=2) policies
; MAXVERBY(IBA) - Maximum width of the 'VC By' column for
; verified (IBA=1) policies
; Output: CAPPT(IDX) - Starting Column position for the 'Last Apt'
; Column for Verified and Non-Verified policies
; CDOD(IDX) - Starting Column position for the 'DoD'
; Column for Verified and Non-Verified policies
; CGRP(IDX) - Starting Column position for the 'Group No'
; Column for Verified and Non-Verified policies
; CINS(IDX) - Starting Column position for the 'Insurance Co.'
; Column for Verified and Non-Verified policies
; CLVBY(IDX) - Starting Column position for the 'VC By'
; Column for Verified and Non-Verified policies
; CLVDAT(IDX) - Starting Column position for the 'Last VC'
; Column for Verified and Non-Verified policies
; CSSN(IDX) - Starting Column position for the 'SSN'
; Column for Verified and Non-Verified policies
S CSSN(IDX)=MAXPT(IDX)+2
S CINS(IDX)=CSSN(IDX)+6
S CGRP(IDX)=CINS(IDX)+MAXINS(IDX)+2
I IDX=1 D
. S CLVDAT(IDX)=CGRP(IDX)+MAXGRP(IDX)+2
. S CLVBY(IDX)=CLVDAT(IDX)+10
. S CAPPT(IDX)=CLVBY(IDX)+MAXVERBY(IDX)+2
E S CAPPT(IDX)=CGRP(IDX)+MAXGRP(IDX)+2
S CDOD(IDX)=CAPPT(IDX)+10
S MAXRPT(IDX)=CDOD(IDX)+8
Q
;IBCOMA1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCOMA1 13968 printed Feb 10, 2021@21:02:41 Page 2
IBCOMA1 ;ALB/CMS/JNM - IDENTIFY ACTIVE POLICIES W/NO EFFECTIVE DATE (CON'T) ; 09-29-2015
+1 ;;2.0;INTEGRATED BILLING;**103,516,528,549**;21-MAR-94;Build 54
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
BEG ; Entry to run Active Policies w/no Effective Date Report
+1 ; Input variables:
+2 ; IBAIB - Required. How to sort
+3 ; 1= Patient Name Range 2= Terminal Digit Range
+4 ; IBSIN - Required. Include Active Policies with
+5 ; 1= Verification Date 2= No Verification Date 3= Both
+6 ;
+7 ; IBRF - Required. Name or Terminal Digit Range Start value
+8 ; IBRL - Required. Name or Terminal Digit Range Go to value
+9 ; IBBDT - Optional. Beginning Verification Date Range
+10 ; IBEDT - Optional. Ending Verification Date Range
+11 ; IBEXCEL - 1 = Excel Format
+12 ;
+13 ; IB*2*549 - New filter variables
+14 ; IBPTYPE - Living/Deceased/Both filter ;
+15 ; IBAPPTS - Last Appointment Date Range Start
+16 ; IBAPPTE - Last Appointment Date Range End
+17 ;
+18 NEW APPTDATA,CAPPT,CDOD,CGRP,CINS,CLVBY,CLVDAT,CSSN,DFN,IBC,IBC0,IBCDA
+19 NEW IBCDA0,IBCDA1,IBI,IBPAGE,IBQUIT,IBTD,IBTMP,IBX,IDX,LASTAPPT,LASTVER
+20 NEW LVDATE,MAXGRP,MAXINS,MAXPT,MAXRPT,MAXVERBY,VA,VADM,VAERR,X,Y
+21 ;
+22 ; Set starting max field sizes to length of header text
+23 FOR IDX=1:1:2
SET MAXPT(IDX)=12
SET MAXINS(IDX)=13
SET MAXGRP(IDX)=9
SET MAXVERBY(IDX)=5
+24 KILL ^TMP("IBCOMA",$JOB)
+25 SET IBPAGE=0
SET IBQUIT=0
+26 ;
+27 ; Set up filter data for the call to SDAPI^SDAMA301 for IB*2*549
+28 IF IBAPPTS>0
SET APPTDATA(1)=IBAPPTS_";"_IBAPPTE
+29 ; Return Appt Date/Time Data
SET APPTDATA("FLDS")=1
+30 ; Return Last Appt
SET APPTDATA("MAX")=-1
+31 KILL ^TMP($JOB,"SDAMA301")
+32 ;
+33 SET IBC=0
FOR
SET IBC=$ORDER(^DPT("AB",IBC))
if 'IBC
QUIT
Begin DoDot:1
+34 SET IBC0=$GET(^DIC(36,IBC,0))
+35 ;
+36 ; If company inactive quit
+37 if $PIECE(IBC0,U,1)=""
QUIT
+38 if $PIECE(IBC0,U,5)=1
QUIT
+39 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("AB",IBC,DFN))
if 'DFN
QUIT
Begin DoDot:2
+40 KILL VA,VADM,VAERR
+41 DO DEM^VADPT
+42 ;
+43 ; IB*2*549 If Pt. deceased and not showing deceased patients quit
+44 IF IBPTYPE=1
IF ($GET(VADM(6))>0)
QUIT
+45 ;
+46 ; IB*2*549 If Pt. not deceased and not showing living patients quit
+47 IF IBPTYPE=2
IF ($GET(VADM(6))'>0)
QUIT
+48 SET VADM(1)=$PIECE($GET(VADM(1)),U,1)
+49 ;
+50 ; I Pt. name out of range quit
+51 if VADM(1)=""
QUIT
+52 IF IBAIB=1
IF VADM(1)]IBRL
QUIT
+53 IF IBAIB=1
IF IBRF]VADM(1)
QUIT
+54 ;
+55 ; I Terminal Digit out of range quit
+56 IF IBAIB=2
SET IBTD=$$TERMDG^IBCONS2(DFN)
if IBTD=""
SET IBTD="000000000"
IF (+IBTD>IBRL)!(IBRF>+IBTD)
QUIT
+57 ;
+58 ; Fix subscript error if terminal digit is null
+59 IF IBAIB=2
IF IBTD=""
SET IBTD=" "
+60 ;
+61 ; IB*2*549 Filter on last appointment date using ICR# 4433
+62 SET APPTDATA(4)=DFN
+63 IF $$SDAPI^SDAMA301(.APPTDATA)>0
Begin DoDot:3
+64 SET LASTAPPT=@$QUERY(^TMP($JOB,"SDAMA301"))
+65 KILL ^TMP($JOB,"SDAMA301")
End DoDot:3
+66 ; Filtering on Appt Date but no date in range
IF '$TEST
SET LASTAPPT=0
IF IBAPPTS>0
QUIT
+67 ;
+68 SET IBCDA=0
FOR
SET IBCDA=$ORDER(^DPT("AB",IBC,DFN,IBCDA))
if 'IBCDA
QUIT
Begin DoDot:3
+69 ;IB*2.0*516/TAZ - Retrieve data from HIPAA compliant fields.
+70 ;S IBCDA0=$G(^DPT(DFN,.312,IBCDA,0)) ;516 - baa
+71 ;516 - baa
SET IBCDA0=$$ZND^IBCNS1(DFN,IBCDA)
+72 ;
+73 ; I Effective Date populated quit
+74 if $PIECE(IBCDA0,U,8)
QUIT
+75 ;
+76 ; I Expiration Date entered and expired quit
+77 IF $PIECE(IBCDA0,U,4)
IF $PIECE(IBCDA0,U,4)'>DT
QUIT
+78 ;
+79 ; Sorting by verification date or no date check
+80 SET IBCDA1=$GET(^DPT(DFN,.312,IBCDA,1))
+81 SET LVDATE=+$PIECE($PIECE(IBCDA1,U,3),".",1)
+82 IF IBSIN=1
IF LVDATE=0
QUIT
+83 IF IBSIN=1
IF IBBDT>0
IF (LVDATE<IBBDT)!(LVDATE>IBEDT)
QUIT
+84 IF IBSIN=2
IF LVDATE>0
QUIT
+85 IF IBSIN=3
IF LVDATE>0
IF IBBDT>0
IF (LVDATE<IBBDT)!(LVDATE>IBEDT)
QUIT
+86 ;
+87 ; Set data line for global
+88 ;S IBTMP(1)=PT NAME^SSN^DATE OF DEATH^LAST APPT DATE
+89 ;S IBTMP(2)=INSURANCE NAME
+90 ;S IBTMP(3)=VERIFICATION DATE^LAST VERIFIED BY^GROUP NUMBER
+91 ;
+92 SET IBTMP(1)=VADM(1)_U_$EXTRACT(VADM(2),6,9)_U_$$FMTE^XLFDT($PIECE(VADM(6),U,1),"2ZD")
+93 SET IBTMP(1)=IBTMP(1)_U_$$FMTE^XLFDT(LASTAPPT,"2ZD")
+94 SET IBTMP(2)=$PIECE(IBC0,U,1)
+95 SET LASTVER=$PIECE(IBCDA1,U,4)
+96 IF LASTVER'=""
SET LASTVER=$PIECE($GET(^VA(200,LASTVER,0)),U)
+97 SET IBTMP(3)=$$FMTE^XLFDT(LVDATE,"2ZD")_U_LASTVER_U_$PIECE(IBCDA0,U,3)
+98 ;
+99 ; Set variable IBI for Verified=1 or Non verified=2
+100 SET IBI=$SELECT(+$PIECE(IBCDA1,U,3):1,1:2)
+101 IF 'IBEXCEL
Begin DoDot:4
+102 DO SETMAX(VADM(1),.MAXPT,IBI)
DO SETMAX($PIECE(IBC0,U,1),.MAXINS,IBI)
+103 DO SETMAX(LASTVER,.MAXVERBY,IBI)
DO SETMAX($PIECE(IBCDA0,U,3),.MAXGRP,IBI)
End DoDot:4
+104 ;
+105 ; Set Global array
+106 SET ^TMP("IBCOMA",$JOB,IBI,$SELECT(IBAIB=2:+IBTD,1:VADM(1)),DFN)=IBTMP(1)
+107 SET ^TMP("IBCOMA",$JOB,IBI,$SELECT(IBAIB=2:+IBTD,1:VADM(1)),DFN,IBC)=IBTMP(2)
+108 SET ^TMP("IBCOMA",$JOB,IBI,$SELECT(IBAIB=2:+IBTD,1:VADM(1)),DFN,IBC,IBCDA)=IBTMP(3)
End DoDot:3
End DoDot:2
End DoDot:1
+109 IF 'IBEXCEL
DO CALCCOLS
+110 IF '$DATA(^TMP("IBCOMA",$JOB))
Begin DoDot:1
+111 DO HD(1)
+112 WRITE !!,"** NO RECORDS FOUND **"
+113 DO ASK^IBCOMC2
End DoDot:1
GOTO QUEQ
+114 DO WRT
+115 WRITE !!,"** END OF REPORT **",!
+116 ;
QUEQ ; Exit clean-UP
+1 WRITE !
+2 DO ^%ZISC
+3 KILL IBAIB,IBAPPTE,IBAPPTS,IBEXCEL,IBPTYPE,IBRF,IBRL,IBSIN,IBTMP,VA,VADM,VAERR,^TMP("IBCOMA",$JOB)
+4 QUIT
+5 ;
HD(IBA) ; Write Heading
+1 ; Input: IBA - 1 - Header for non-verified policies
+2 ; 2 - Header for verified policies
+3 ; CAPPT(IBA) - Starting Column Position for the 'Last Apt' Column
+4 ; CDOD(IBA) - Starting Column Position for the 'DoD' Column
+5 ; CGRP(IBA) - Starting Column Position for the 'Group No.' Column
+6 ; CINS(IBA) - Starting Column Position for the 'Insurance Co.' Column
+7 ; CSSN(IBA) - Starting Column Position for the 'SSN' Column
+8 ; CLVDAT(IBA) - Starting Column Position for the 'Last VC' Column
+9 ; CLVBY(IBA) - Starting Column Position for the 'VC By' Column
+10 ; IBPAGE - Current Page Number
+11 ; MAXRPT(IBA) - Maximum number of characters in column header line
+12 ; Output: IBPAGE - Updated Page Number
+13 ;
+14 ; IB*2.0*549 changed include Appoint Date filtering and
+15 ; dynamic column width based on actual data sizes
+16 IF IBEXCEL
Begin DoDot:1
+17 DO PGHD(0)
+18 WRITE !!,"Patient Name^SSN^Insurance Co.^Group No.^Last VC^VC By^Last Apt^DoD"
End DoDot:1
IF 1
+19 IF '$TEST
Begin DoDot:1
+20 SET IBPAGE=IBPAGE+1
+21 DO PGHD(IBPAGE)
+22 WRITE !!,"Patient Name",?CSSN(IBA),"SSN",?CINS(IBA),"Insurance Co.",?CGRP(IBA),"Group No."
+23 IF IBA=1
WRITE ?CLVDAT(IBA),"Last VC",?CLVBY(IBA),"VC By"
+24 WRITE ?CAPPT(IBA),"Last Apt",?CDOD(IBA),"DoD"
+25 WRITE !
+26 FOR IBX=1:1:MAXRPT(IBA)
WRITE "="
End DoDot:1
+27 QUIT
+28 ;
PGHD(IBPAGE) ; Print Report Page Header
+1 ; Input: IBPAGE - Current Page Number, 0 if exporting to Excel
+2 ; IBAIB - 1 Sorting by Patient Name, 2 - Sorting by Terminal Digit
+3 ; IBAPPTE - Internal Appointment Date Range End
+4 ; 0 if no Appointment Date Range filter
+5 ; IBAPPTS - Internal Appointment Date Range Start
+6 ; 0 if no Appointment Date Range filter
+7 ; IBBDT - Internal Verification Start date for Verification filter
+8 ; Null if no Verification filter
+9 ; IBEDT - Internal Verification End date for Verification filter
+10 ; Null if no Verification filter
+11 ; IBRF - "A" - First Patient Name, otherwise start of range filter
+12 ; IBRL - End of range filter
+13 ;
+14 NEW IBHDT
+15 SET IBHDT=$$FMTE^XLFDT($$NOW^XLFDT,"Z")
+16 if IBPAGE
WRITE @IOF
+17 if 'IBPAGE
WRITE !!
+18 WRITE "Active Policies with no Effective Date Report "
+19 IF 'IBPAGE
Begin DoDot:1
+20 WRITE " Run On: ",IBHDT
End DoDot:1
+21 IF '$TEST
Begin DoDot:1
+22 WRITE ?IOM-34,IBHDT,?IOM-10,"Page: ",IBPAGE
End DoDot:1
+23 IF IBPAGE
WRITE !,?5,"Sorted by: "
+24 IF '$TEST
WRITE !,?6,"Contains: "
+25 WRITE $SELECT(IBAIB=1:"Patient Name",1:"Terminal Digit")
+26 WRITE " Range: "_$SELECT(IBRF="A":"FIRST",1:IBRF)_" to "_$SELECT(IBRL="zzzzzz":"LAST",1:IBRL)
+27 IF IBBDT>0
Begin DoDot:1
+28 WRITE !,?7,"Include: Verification Date Range: "_$$FMTE^XLFDT(IBBDT,"Z")
+29 WRITE " to "_$$FMTE^XLFDT(IBEDT,"Z")
End DoDot:1
+30 IF IBAPPTS>0
Begin DoDot:1
+31 WRITE !,?7,"Include: Last Appointment Date Range: "_$$FMTE^XLFDT(IBAPPTS,"Z")
+32 WRITE " to "_$$FMTE^XLFDT(IBAPPTE,"Z")
End DoDot:1
+33 WRITE !,?8,"Filter: "_$SELECT(IBPTYPE=1:"Living Patients",IBPTYPE=2:"Deceased Patients",1:"Both Living & Deceased Patients")
+34 WRITE ", "_$SELECT(IBSIN=1:"Verified Policies",IBSIN=2:"Non-Verified Policies",1:"Both Verified & Non-Verified Policies")
+35 QUIT
+36 ;
WRT ; Write data lines
+1 NEW IBA,IBCDA,IBDA,IBFIRST,IBDFN,IBINS,IBNA,IBPOL,IBPT,X,Y
+2 SET IBQUIT=0
SET IBFIRST=1
+3 SET IBA=0
FOR
SET IBA=$ORDER(^TMP("IBCOMA",$JOB,IBA))
if ('IBA)!(IBQUIT=1)
QUIT
Begin DoDot:1
+4 IF IBPAGE
DO ASK^IBCOMC2
IF IBQUIT=1
QUIT
+5 IF IBEXCEL
IF IBFIRST
Begin DoDot:2
+6 DO HD(IBA)
+7 SET IBFIRST=0
End DoDot:2
+8 ;
+9 IF 'IBEXCEL
Begin DoDot:2
+10 DO HD(IBA)
+11 WRITE !,$SELECT(IBA=1:"Verified",1:"Non-Verified"),!
End DoDot:2
+12 SET IBNA=""
FOR
SET IBNA=$ORDER(^TMP("IBCOMA",$JOB,IBA,IBNA))
if (IBNA="")!(IBQUIT=1)
QUIT
Begin DoDot:2
+13 SET IBDFN=0
FOR
SET IBDFN=$ORDER(^TMP("IBCOMA",$JOB,IBA,IBNA,IBDFN))
if ('IBDFN)!(IBQUIT=1)
QUIT
Begin DoDot:3
+14 SET IBPT=$GET(^TMP("IBCOMA",$JOB,IBA,IBNA,IBDFN))
+15 ;
+16 IF 'IBEXCEL
IF ($Y+7)>IOSL
Begin DoDot:4
+17 DO ASK^IBCOMC2
IF IBQUIT=1
QUIT
+18 DO HD(IBA)
End DoDot:4
IF IBQUIT=1
QUIT
+19 ;
+20 SET IBDA=0
FOR
SET IBDA=$ORDER(^TMP("IBCOMA",$JOB,IBA,IBNA,IBDFN,IBDA))
if ('IBDA)!(IBQUIT=1)
QUIT
Begin DoDot:4
+21 SET IBINS=$GET(^TMP("IBCOMA",$JOB,IBA,IBNA,IBDFN,IBDA))
+22 ;
+23 SET IBCDA=0
FOR
SET IBCDA=$ORDER(^TMP("IBCOMA",$JOB,IBA,IBNA,IBDFN,IBDA,IBCDA))
if ('IBCDA)!(IBQUIT=1)
QUIT
Begin DoDot:5
+24 SET IBPOL=$GET(^TMP("IBCOMA",$JOB,IBA,IBNA,IBDFN,IBDA,IBCDA))
+25 IF IBEXCEL
Begin DoDot:6
+26 WRITE !,$PIECE(IBPT,U,1),U,$PIECE(IBPT,U,2),U,$PIECE(IBINS,U,1),U,$PIECE(IBPOL,U,3),U
+27 IF $PIECE(IBPOL,U,1)'=0
WRITE $PIECE(IBPOL,U,1)
+28 WRITE U_$PIECE(IBPOL,U,2)_U
+29 WRITE $PIECE(IBPT,U,4),U,$PIECE(IBPT,U,3)
End DoDot:6
IF 1
+30 IF '$TEST
Begin DoDot:6
+31 WRITE !,$EXTRACT($PIECE(IBPT,U,1),1,MAXPT(IBA)),?CSSN(IBA),$PIECE(IBPT,U,2),?CINS(IBA)
+32 WRITE $EXTRACT($PIECE(IBINS,U,1),1,MAXINS(IBA)),?CGRP(IBA),$EXTRACT($PIECE(IBPOL,U,3),1,MAXGRP(IBA))
+33 IF IBA=1
WRITE ?CLVDAT(IBA),$PIECE(IBPOL,U,1),?CLVBY(IBA),$EXTRACT($PIECE(IBPOL,U,2),1,MAXVERBY(IBA))
+34 WRITE ?CAPPT(IBA),$PIECE(IBPT,U,4),?CDOD(IBA),$PIECE(IBPT,U,3)
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+35 QUIT
+36 ;
SETMAX(NAME,MAX,IBI) ; Get max length of data
+1 ; Input: NAME - Data to get maximum length for
+2 ; MAX(IBI)- Current Max length array
+3 ; IBI - Verified or Non-Verified section of the array
+4 ; Output MAX(IBI)- Updated Max length array (potentially)
+5 NEW LEN
+6 SET LEN=$LENGTH(NAME)
+7 IF LEN>MAX(IBI)
SET MAX(IBI)=LEN
+8 QUIT
+9 ;
CALCCOLS ; Truncates the patient and insurance name field lengths if the total
+1 ; field lengths will not fit on the report (132 columns)
+2 ; Input: MAXGRP(IBA) - Maximum width of the 'Group No' column for
+3 ; verified (IBA=1) and non-verified (IBA=2) policies
+4 ; MAXINS(IBA) - Current Maximum width of the 'Insurance Co' column for
+5 ; verified (IBA=1) and non-verified (IBA=2) policies
+6 ; MAXPT(IBA) - Current Maximum width of the 'Patient Name' column for
+7 ; verified (IBA=1) and non-verified (IBA=2) policies
+8 ; MAXVERBY(IBA) - Maximum width of the 'VC By' column for
+9 ; verified (IBA=1) policies
+10 ; Output: MAXINS(IBA) - Updated Maximum width of the 'Insurance Co' column for
+11 ; verified (IBA=1) and non-verified (IBA=2) policies
+12 ; MAXPT(IBA) - Updated Maximum width of the 'Patient Name' column for
+13 ; verified (IBA=1) and non-verified (IBA=2) policies
+14 NEW DIFF,DIFF2,DIFF3,IDX,MAX
+15 ; MAX=131 - SSN(4) - 3 Dates(24) - 14 (Spaces between columns)
SET MAX(1)=89
+16 ; MAX=131 - SSN(4) - 2 Dates(16) - 10 (Spaces between columns)
SET MAX(2)=101
+17 FOR IDX=1:1:2
Begin DoDot:1
+18 SET DIFF=MAX(IDX)-MAXPT(IDX)-MAXINS(IDX)-MAXGRP(IDX)
+19 IF IDX=1
SET DIFF=DIFF-MAXVERBY(IDX)
+20 IF DIFF<0
Begin DoDot:2
+21 SET DIFF2=(-DIFF)\2
+22 SET DIFF3=(-DIFF)-DIFF2
+23 SET MAXPT(IDX)=MAXPT(IDX)-DIFF2
+24 SET MAXINS(IDX)=MAXINS(IDX)-DIFF3
End DoDot:2
+25 DO SETCOLS(IDX)
End DoDot:1
+26 QUIT
+27 ;
SETCOLS(IDX) ; Sets the column positions based on maximum data sizes
+1 ; Input: IDX - 1 - Verified policies section of the report
+2 ; 2 - Non-Verified policies section of the report
+3 ; MAXGRP(IBA) - Maximum width of the 'Group No' column for
+4 ; verified (IBA=1) and non-verified (IBA=2) policies
+5 ; MAXINS(IBA) - Maximum width of the 'Insurance Co' column for
+6 ; verified (IBA=1) and non-verified (IBA=2) policies
+7 ; MAXPT(IBA) - Maximum width of the 'Patient Name' column for
+8 ; verified (IBA=1) and non-verified (IBA=2) policies
+9 ; MAXVERBY(IBA) - Maximum width of the 'VC By' column for
+10 ; verified (IBA=1) policies
+11 ; Output: CAPPT(IDX) - Starting Column position for the 'Last Apt'
+12 ; Column for Verified and Non-Verified policies
+13 ; CDOD(IDX) - Starting Column position for the 'DoD'
+14 ; Column for Verified and Non-Verified policies
+15 ; CGRP(IDX) - Starting Column position for the 'Group No'
+16 ; Column for Verified and Non-Verified policies
+17 ; CINS(IDX) - Starting Column position for the 'Insurance Co.'
+18 ; Column for Verified and Non-Verified policies
+19 ; CLVBY(IDX) - Starting Column position for the 'VC By'
+20 ; Column for Verified and Non-Verified policies
+21 ; CLVDAT(IDX) - Starting Column position for the 'Last VC'
+22 ; Column for Verified and Non-Verified policies
+23 ; CSSN(IDX) - Starting Column position for the 'SSN'
+24 ; Column for Verified and Non-Verified policies
+25 SET CSSN(IDX)=MAXPT(IDX)+2
+26 SET CINS(IDX)=CSSN(IDX)+6
+27 SET CGRP(IDX)=CINS(IDX)+MAXINS(IDX)+2
+28 IF IDX=1
Begin DoDot:1
+29 SET CLVDAT(IDX)=CGRP(IDX)+MAXGRP(IDX)+2
+30 SET CLVBY(IDX)=CLVDAT(IDX)+10
+31 SET CAPPT(IDX)=CLVBY(IDX)+MAXVERBY(IDX)+2
End DoDot:1
+32 IF '$TEST
SET CAPPT(IDX)=CGRP(IDX)+MAXGRP(IDX)+2
+33 SET CDOD(IDX)=CAPPT(IDX)+10
+34 SET MAXRPT(IDX)=CDOD(IDX)+8
+35 QUIT
+36 ;IBCOMA1
