IBCOMA1 ;ALB/CMS/JNM - IDENTIFY ACTIVE POLICIES W/NO EFFECTIVE DATE (CON'T) ; 09-29-2015
;;2.0;INTEGRATED BILLING;**103,516,528,549,743,752**;21-MAR-94;Build 20
;;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
N IBVANM S IBVANM="" ;IB*752/DTG - new variable for case insensitive
;
; 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)=""
. . ;IB*752/DTG - case insensitive check inclusive
. . S IBVANM=$$UP^XLFSTR(VADM(1))
. . ;I IBAIB=1,VADM(1)]IBRL Q
. . ;I IBAIB=1,IBRF]VADM(1) Q
. . I IBAIB=1,$E(IBVANM,1,$L(IBRLU))]IBRLU Q
. . I IBAIB=1,IBRFU]$E(IBVANM,1,$L(IBRFU)) 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 EOR,ASK^IBCOMC2 ; IB*752/DTG - print EOR then pause
D WRT
;IB*752/DTG - end of report then pause
;W !!,"** END OF REPORT **",!
I '$G(IBQUIT) D EOR,ASK^IBCOMC2
;
QUEQ ; Exit clean-UP
W !
D ^%ZISC
K IBAIB,IBAPPTE,IBAPPTS,IBEXCEL,IBPTYPE,IBRF,IBRL,IBSIN,IBTMP,VA,VADM,VAERR,^TMP("IBCOMA",$J)
K IBVANM ;IB*752/DTG - variable for case insensitive
Q
;
;IB*752/DTG - end of report
EOR ; end of report
;
W !!,"** END OF REPORT **",!
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
. I +IBPAGE>0 Q ;IB*752/DTG correct header
. D PGHD(0)
. W !,"Patient Name^SSN^Insurance Co.^Group No.^Last VC^VC By^Last Apt^DoD"
;IB*752/DTG remove excel else
;E D
I 'IBEXCEL 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
; IB*743/TAZ - Modified IBRF to note NULL starts with the beginning of the list.
; IBRF - "" - 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 "
;IB*752/DTG correct header for excel
I IBEXCEL D Q
. W " Run On: ",IBHDT
. W !,"Filtered by: " ;IB*752/DTG - change sort to filter
. W " Range: "_$S(IBRF="":"FIRST",1:IBRF)_" to "_$S(IBRL="zzzzzz":"LAST",1:IBRL)
. I IBBDT>0 D
. . W !,"Include: Verification Date Range: "_$$FMTE^XLFDT(IBBDT,"Z")
. . W " to "_$$FMTE^XLFDT(IBEDT,"Z")
. I IBAPPTS>0 D
. . W !,"Include: Last Appointment Date Range: "_$$FMTE^XLFDT(IBAPPTS,"Z")
. . W " to "_$$FMTE^XLFDT(IBAPPTE,"Z")
. W !,"Filter: "
. W $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")
;E D
;. W ?IOM-34,IBHDT,?IOM-10,"Page: ",IBPAGE
W ?IOM-34,IBHDT,?IOM-10,"Page: ",IBPAGE
;I IBPAGE W !,?5,"Filtered by: " ;IB*752/DTG - change sort to filter
W !,?5,"Filtered by: " ;IB*752/DTG - change sort to filter
;E W !,?6,"Contains: "
W $S(IBAIB=1:"Patient Name",1:"Terminal Digit")
;IB*743/TAZ - Modified Check on IBRF.
;W " Range: "_$S(IBRF="A":"FIRST",1:IBRF)_" to "_$S(IBRL="zzzzzz":"LAST",1:IBRL)
W " Range: "_$S(IBRF="":"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,IBLS,IBNA,IBPOL,IBPT,X,Y
S IBQUIT=0,IBFIRST=1,IBLS="" ;IB*752/DTG added in IBLS for track of IBA change
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
. ;IB*752/DTG change for proper excel header
. ;I IBEXCEL,IBFIRST D
. ;. D HD(IBA)
. ;. S IBFIRST=0
. I IBEXCEL D
. . I 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))
. . . . . ;IB*752/DTG correct if and else to if's
. . . . . ;I IBEXCEL D I 1
. . . . . I IBEXCEL D
. . . . . . 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
. . . . . I 'IBEXCEL 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 15916 printed Sep 23, 2025@19:54:31 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,743,752**;21-MAR-94;Build 20
+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 ;IB*752/DTG - new variable for case insensitive
NEW IBVANM
SET IBVANM=""
+22 ;
+23 ; Set starting max field sizes to length of header text
+24 FOR IDX=1:1:2
SET MAXPT(IDX)=12
SET MAXINS(IDX)=13
SET MAXGRP(IDX)=9
SET MAXVERBY(IDX)=5
+25 KILL ^TMP("IBCOMA",$JOB)
+26 SET IBPAGE=0
SET IBQUIT=0
+27 ;
+28 ; Set up filter data for the call to SDAPI^SDAMA301 for IB*2*549
+29 IF IBAPPTS>0
SET APPTDATA(1)=IBAPPTS_";"_IBAPPTE
+30 ; Return Appt Date/Time Data
SET APPTDATA("FLDS")=1
+31 ; Return Last Appt
SET APPTDATA("MAX")=-1
+32 KILL ^TMP($JOB,"SDAMA301")
+33 ;
+34 SET IBC=0
FOR
SET IBC=$ORDER(^DPT("AB",IBC))
if 'IBC
QUIT
Begin DoDot:1
+35 SET IBC0=$GET(^DIC(36,IBC,0))
+36 ;
+37 ; If company inactive quit
+38 if $PIECE(IBC0,U,1)=""
QUIT
+39 if $PIECE(IBC0,U,5)=1
QUIT
+40 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("AB",IBC,DFN))
if 'DFN
QUIT
Begin DoDot:2
+41 KILL VA,VADM,VAERR
+42 DO DEM^VADPT
+43 ;
+44 ; IB*2*549 If Pt. deceased and not showing deceased patients quit
+45 IF IBPTYPE=1
IF ($GET(VADM(6))>0)
QUIT
+46 ;
+47 ; IB*2*549 If Pt. not deceased and not showing living patients quit
+48 IF IBPTYPE=2
IF ($GET(VADM(6))'>0)
QUIT
+49 SET VADM(1)=$PIECE($GET(VADM(1)),U,1)
+50 ;
+51 ; I Pt. name out of range quit
+52 if VADM(1)=""
QUIT
+53 ;IB*752/DTG - case insensitive check inclusive
+54 SET IBVANM=$$UP^XLFSTR(VADM(1))
+55 ;I IBAIB=1,VADM(1)]IBRL Q
+56 ;I IBAIB=1,IBRF]VADM(1) Q
+57 IF IBAIB=1
IF $EXTRACT(IBVANM,1,$LENGTH(IBRLU))]IBRLU
QUIT
+58 IF IBAIB=1
IF IBRFU]$EXTRACT(IBVANM,1,$LENGTH(IBRFU))
QUIT
+59 ;
+60 ; I Terminal Digit out of range quit
+61 IF IBAIB=2
SET IBTD=$$TERMDG^IBCONS2(DFN)
if IBTD=""
SET IBTD="000000000"
IF (+IBTD>IBRL)!(IBRF>+IBTD)
QUIT
+62 ;
+63 ; Fix subscript error if terminal digit is null
+64 IF IBAIB=2
IF IBTD=""
SET IBTD=" "
+65 ;
+66 ; IB*2*549 Filter on last appointment date using ICR# 4433
+67 SET APPTDATA(4)=DFN
+68 IF $$SDAPI^SDAMA301(.APPTDATA)>0
Begin DoDot:3
+69 SET LASTAPPT=@$QUERY(^TMP($JOB,"SDAMA301"))
+70 KILL ^TMP($JOB,"SDAMA301")
End DoDot:3
+71 ; Filtering on Appt Date but no date in range
IF '$TEST
SET LASTAPPT=0
IF IBAPPTS>0
QUIT
+72 ;
+73 SET IBCDA=0
FOR
SET IBCDA=$ORDER(^DPT("AB",IBC,DFN,IBCDA))
if 'IBCDA
QUIT
Begin DoDot:3
+74 ;IB*2.0*516/TAZ - Retrieve data from HIPAA compliant fields.
+75 ;S IBCDA0=$G(^DPT(DFN,.312,IBCDA,0)) ;516 - baa
+76 ;516 - baa
SET IBCDA0=$$ZND^IBCNS1(DFN,IBCDA)
+77 ;
+78 ; I Effective Date populated quit
+79 if $PIECE(IBCDA0,U,8)
QUIT
+80 ;
+81 ; I Expiration Date entered and expired quit
+82 IF $PIECE(IBCDA0,U,4)
IF $PIECE(IBCDA0,U,4)'>DT
QUIT
+83 ;
+84 ; Sorting by verification date or no date check
+85 SET IBCDA1=$GET(^DPT(DFN,.312,IBCDA,1))
+86 SET LVDATE=+$PIECE($PIECE(IBCDA1,U,3),".",1)
+87 IF IBSIN=1
IF LVDATE=0
QUIT
+88 IF IBSIN=1
IF IBBDT>0
IF (LVDATE<IBBDT)!(LVDATE>IBEDT)
QUIT
+89 IF IBSIN=2
IF LVDATE>0
QUIT
+90 IF IBSIN=3
IF LVDATE>0
IF IBBDT>0
IF (LVDATE<IBBDT)!(LVDATE>IBEDT)
QUIT
+91 ;
+92 ; Set data line for global
+93 ;S IBTMP(1)=PT NAME^SSN^DATE OF DEATH^LAST APPT DATE
+94 ;S IBTMP(2)=INSURANCE NAME
+95 ;S IBTMP(3)=VERIFICATION DATE^LAST VERIFIED BY^GROUP NUMBER
+96 ;
+97 SET IBTMP(1)=VADM(1)_U_$EXTRACT(VADM(2),6,9)_U_$$FMTE^XLFDT($PIECE(VADM(6),U,1),"2ZD")
+98 SET IBTMP(1)=IBTMP(1)_U_$$FMTE^XLFDT(LASTAPPT,"2ZD")
+99 SET IBTMP(2)=$PIECE(IBC0,U,1)
+100 SET LASTVER=$PIECE(IBCDA1,U,4)
+101 IF LASTVER'=""
SET LASTVER=$PIECE($GET(^VA(200,LASTVER,0)),U)
+102 SET IBTMP(3)=$$FMTE^XLFDT(LVDATE,"2ZD")_U_LASTVER_U_$PIECE(IBCDA0,U,3)
+103 ;
+104 ; Set variable IBI for Verified=1 or Non verified=2
+105 SET IBI=$SELECT(+$PIECE(IBCDA1,U,3):1,1:2)
+106 IF 'IBEXCEL
Begin DoDot:4
+107 DO SETMAX(VADM(1),.MAXPT,IBI)
DO SETMAX($PIECE(IBC0,U,1),.MAXINS,IBI)
+108 DO SETMAX(LASTVER,.MAXVERBY,IBI)
DO SETMAX($PIECE(IBCDA0,U,3),.MAXGRP,IBI)
End DoDot:4
+109 ;
+110 ; Set Global array
+111 SET ^TMP("IBCOMA",$JOB,IBI,$SELECT(IBAIB=2:+IBTD,1:VADM(1)),DFN)=IBTMP(1)
+112 SET ^TMP("IBCOMA",$JOB,IBI,$SELECT(IBAIB=2:+IBTD,1:VADM(1)),DFN,IBC)=IBTMP(2)
+113 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
+114 IF 'IBEXCEL
DO CALCCOLS
+115 IF '$DATA(^TMP("IBCOMA",$JOB))
Begin DoDot:1
+116 DO HD(1)
+117 WRITE !!,"** NO RECORDS FOUND **"
+118 ; IB*752/DTG - print EOR then pause
DO EOR
DO ASK^IBCOMC2
End DoDot:1
GOTO QUEQ
+119 DO WRT
+120 ;IB*752/DTG - end of report then pause
+121 ;W !!,"** END OF REPORT **",!
+122 IF '$GET(IBQUIT)
DO EOR
DO ASK^IBCOMC2
+123 ;
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 ;IB*752/DTG - variable for case insensitive
KILL IBVANM
+5 QUIT
+6 ;
+7 ;IB*752/DTG - end of report
EOR ; end of report
+1 ;
+2 WRITE !!,"** END OF REPORT **",!
+3 QUIT
+4 ;
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 ;IB*752/DTG correct header
IF +IBPAGE>0
QUIT
+18 DO PGHD(0)
+19 WRITE !,"Patient Name^SSN^Insurance Co.^Group No.^Last VC^VC By^Last Apt^DoD"
End DoDot:1
IF 1
+20 ;IB*752/DTG remove excel else
+21 ;E D
+22 IF 'IBEXCEL
Begin DoDot:1
+23 SET IBPAGE=IBPAGE+1
+24 DO PGHD(IBPAGE)
+25 WRITE !!,"Patient Name",?CSSN(IBA),"SSN",?CINS(IBA),"Insurance Co.",?CGRP(IBA),"Group No."
+26 IF IBA=1
WRITE ?CLVDAT(IBA),"Last VC",?CLVBY(IBA),"VC By"
+27 WRITE ?CAPPT(IBA),"Last Apt",?CDOD(IBA),"DoD"
+28 WRITE !
+29 FOR IBX=1:1:MAXRPT(IBA)
WRITE "="
End DoDot:1
+30 QUIT
+31 ;
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 ; IB*743/TAZ - Modified IBRF to note NULL starts with the beginning of the list.
+12 ; IBRF - "" - First Patient Name, otherwise start of range filter
+13 ; IBRL - End of range filter
+14 ;
+15 NEW IBHDT
+16 SET IBHDT=$$FMTE^XLFDT($$NOW^XLFDT,"Z")
+17 if IBPAGE
WRITE @IOF
+18 if 'IBPAGE
WRITE !!
+19 WRITE "Active Policies with no Effective Date Report "
+20 ;IB*752/DTG correct header for excel
+21 IF IBEXCEL
Begin DoDot:1
+22 WRITE " Run On: ",IBHDT
+23 ;IB*752/DTG - change sort to filter
WRITE !,"Filtered by: "
+24 WRITE " Range: "_$SELECT(IBRF="":"FIRST",1:IBRF)_" to "_$SELECT(IBRL="zzzzzz":"LAST",1:IBRL)
+25 IF IBBDT>0
Begin DoDot:2
+26 WRITE !,"Include: Verification Date Range: "_$$FMTE^XLFDT(IBBDT,"Z")
+27 WRITE " to "_$$FMTE^XLFDT(IBEDT,"Z")
End DoDot:2
+28 IF IBAPPTS>0
Begin DoDot:2
+29 WRITE !,"Include: Last Appointment Date Range: "_$$FMTE^XLFDT(IBAPPTS,"Z")
+30 WRITE " to "_$$FMTE^XLFDT(IBAPPTE,"Z")
End DoDot:2
+31 WRITE !,"Filter: "
+32 WRITE $SELECT(IBPTYPE=1:"Living Patients",IBPTYPE=2:"Deceased Patients",1:"Both Living & Deceased Patients")
+33 WRITE ", "_$SELECT(IBSIN=1:"Verified Policies",IBSIN=2:"Non-Verified Policies",1:"Both Verified & Non-Verified Policies")
End DoDot:1
QUIT
+34 ;E D
+35 ;. W ?IOM-34,IBHDT,?IOM-10,"Page: ",IBPAGE
+36 WRITE ?IOM-34,IBHDT,?IOM-10,"Page: ",IBPAGE
+37 ;I IBPAGE W !,?5,"Filtered by: " ;IB*752/DTG - change sort to filter
+38 ;IB*752/DTG - change sort to filter
WRITE !,?5,"Filtered by: "
+39 ;E W !,?6,"Contains: "
+40 WRITE $SELECT(IBAIB=1:"Patient Name",1:"Terminal Digit")
+41 ;IB*743/TAZ - Modified Check on IBRF.
+42 ;W " Range: "_$S(IBRF="A":"FIRST",1:IBRF)_" to "_$S(IBRL="zzzzzz":"LAST",1:IBRL)
+43 WRITE " Range: "_$SELECT(IBRF="":"FIRST",1:IBRF)_" to "_$SELECT(IBRL="zzzzzz":"LAST",1:IBRL)
+44 IF IBBDT>0
Begin DoDot:1
+45 WRITE !,?7,"Include: Verification Date Range: "_$$FMTE^XLFDT(IBBDT,"Z")
+46 WRITE " to "_$$FMTE^XLFDT(IBEDT,"Z")
End DoDot:1
+47 IF IBAPPTS>0
Begin DoDot:1
+48 WRITE !,?7,"Include: Last Appointment Date Range: "_$$FMTE^XLFDT(IBAPPTS,"Z")
+49 WRITE " to "_$$FMTE^XLFDT(IBAPPTE,"Z")
End DoDot:1
+50 WRITE !,?8,"Filter: "_$SELECT(IBPTYPE=1:"Living Patients",IBPTYPE=2:"Deceased Patients",1:"Both Living & Deceased Patients")
+51 WRITE ", "_$SELECT(IBSIN=1:"Verified Policies",IBSIN=2:"Non-Verified Policies",1:"Both Verified & Non-Verified Policies")
+52 QUIT
+53 ;
WRT ; Write data lines
+1 NEW IBA,IBCDA,IBDA,IBFIRST,IBDFN,IBINS,IBLS,IBNA,IBPOL,IBPT,X,Y
+2 ;IB*752/DTG added in IBLS for track of IBA change
SET IBQUIT=0
SET IBFIRST=1
SET IBLS=""
+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 ;IB*752/DTG change for proper excel header
+6 ;I IBEXCEL,IBFIRST D
+7 ;. D HD(IBA)
+8 ;. S IBFIRST=0
+9 IF IBEXCEL
Begin DoDot:2
+10 IF IBFIRST
Begin DoDot:3
+11 DO HD(IBA)
+12 SET IBFIRST=0
End DoDot:3
End DoDot:2
+13 ;
+14 IF 'IBEXCEL
Begin DoDot:2
+15 DO HD(IBA)
+16 WRITE !,$SELECT(IBA=1:"Verified",1:"Non-Verified"),!
End DoDot:2
+17 SET IBNA=""
FOR
SET IBNA=$ORDER(^TMP("IBCOMA",$JOB,IBA,IBNA))
if (IBNA="")!(IBQUIT=1)
QUIT
Begin DoDot:2
+18 SET IBDFN=0
FOR
SET IBDFN=$ORDER(^TMP("IBCOMA",$JOB,IBA,IBNA,IBDFN))
if ('IBDFN)!(IBQUIT=1)
QUIT
Begin DoDot:3
+19 SET IBPT=$GET(^TMP("IBCOMA",$JOB,IBA,IBNA,IBDFN))
+20 ;
+21 IF 'IBEXCEL
IF ($Y+7)>IOSL
Begin DoDot:4
+22 DO ASK^IBCOMC2
IF IBQUIT=1
QUIT
+23 DO HD(IBA)
End DoDot:4
IF IBQUIT=1
QUIT
+24 ;
+25 SET IBDA=0
FOR
SET IBDA=$ORDER(^TMP("IBCOMA",$JOB,IBA,IBNA,IBDFN,IBDA))
if ('IBDA)!(IBQUIT=1)
QUIT
Begin DoDot:4
+26 SET IBINS=$GET(^TMP("IBCOMA",$JOB,IBA,IBNA,IBDFN,IBDA))
+27 ;
+28 SET IBCDA=0
FOR
SET IBCDA=$ORDER(^TMP("IBCOMA",$JOB,IBA,IBNA,IBDFN,IBDA,IBCDA))
if ('IBCDA)!(IBQUIT=1)
QUIT
Begin DoDot:5
+29 SET IBPOL=$GET(^TMP("IBCOMA",$JOB,IBA,IBNA,IBDFN,IBDA,IBCDA))
+30 ;IB*752/DTG correct if and else to if's
+31 ;I IBEXCEL D I 1
+32 IF IBEXCEL
Begin DoDot:6
+33 WRITE !,$PIECE(IBPT,U,1),U,$PIECE(IBPT,U,2),U,$PIECE(IBINS,U,1),U,$PIECE(IBPOL,U,3),U
+34 IF $PIECE(IBPOL,U,1)'=0
WRITE $PIECE(IBPOL,U,1)
+35 WRITE U_$PIECE(IBPOL,U,2)_U
+36 WRITE $PIECE(IBPT,U,4),U,$PIECE(IBPT,U,3)
End DoDot:6
+37 ;E D
+38 IF 'IBEXCEL
Begin DoDot:6
+39 WRITE !,$EXTRACT($PIECE(IBPT,U,1),1,MAXPT(IBA)),?CSSN(IBA),$PIECE(IBPT,U,2),?CINS(IBA)
+40 WRITE $EXTRACT($PIECE(IBINS,U,1),1,MAXINS(IBA)),?CGRP(IBA),$EXTRACT($PIECE(IBPOL,U,3),1,MAXGRP(IBA))
+41 IF IBA=1
WRITE ?CLVDAT(IBA),$PIECE(IBPOL,U,1),?CLVBY(IBA),$EXTRACT($PIECE(IBPOL,U,2),1,MAXVERBY(IBA))
+42 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
+43 QUIT
+44 ;
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
