IBCOMN1 ;ALB/CMS - PATIENTS NO COVERAGE VERIFIED REPORT (CON'T);10-09-98
;;2.0;INTEGRATED BILLING;**103,528,602,743,752**;21-MAR-94;Build 20
;;Per VA Directive 6402, this routine should not be modified.
Q
;
BEG ; Entry to run Patients w/no Coverage Verification Report
; Input variables:
; IBAIB - Required. How to sort
; 1= Patient Name Range 2= Terminal Digit Range
;
; IBRF - Required. Name or Terminal Digit Range Start value
; IBRL - Required. Name or Terminal Digit Range Go to value
; IBBDT - Required. Begining Verification Date Range
; IBEDT - Required. Ending Verification Date Range
; IBOUT - Required. Output format
; "R"= report format "E"= Excel format
;
N DFN,IBDT,IBGP,IBI,IBQUIT,IBPAGE,IBTMP,IBTD,IBX,VA,VADM,VAERR,X,Y
N IBVANM S IBVANM="" ;IB*752/DTG - new variable for case insensitive
;
I "^R^E^"'[(U_$G(IBOUT)_U) S IBOUT="R"
K ^TMP("IBCOMN",$J) S IBPAGE=0,IBQUIT=0
S IBDT=IBBDT F S IBDT=$O(^IBA(354,"AVDT",IBDT)) Q:('IBDT)!(IBDT>IBEDT) D
.S DFN=0 F S DFN=$O(^IBA(354,"AVDT",IBDT,DFN)) Q:'DFN D
..K VA,VADM,VAERR,VAPA
..D DEM^VADPT,ADD^VADPT
..;
..; I Pt. name out of range quit
..S VADM(1)=$P($G(VADM(1)),U,1) I VADM(1)="" Q
..;IB*752/DTG - case insensitive check
..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) I (+IBTD>IBRL)!(IBRF>+IBTD) Q
..;
..; Fix subscript error if terminal digit is null
..I IBAIB=2,IBTD="" S IBTD=" "
..;
..; set data line, set global * if deceased
..;S IBTMP=PT NAME^SSN^AGE^DOB^HOME PHONE^VERIFICATION NO COV
..S IBTMP=$S($G(VADM(6)):"*",1:"")_VADM(1)_U_$P($P(VADM(2),U,2),"-",3)_U_+VADM(4)_U_$$FMTE^XLFDT(VADM(3),"5ZD")_U_$P(VAPA(8),U,1)_U_$$FMTE^XLFDT(IBDT,"5ZD")
..S ^TMP("IBCOMN",$J,$S(IBAIB=2:IBTD,1:VADM(1)),DFN)=IBTMP
..;
;
I '$D(^TMP("IBCOMN",$J)) D HD W !!,"** NO RECORDS FOUND **" D EOR,ASK G QUEQ
D HD,WRT
;
QUEQ ; Exit clean-UP
W ! D ^%ZISC K IBTMP,IBAIB,IBOUT,IBRF,IBRL,VA,VAERR,VADM,VAPA,^TMP("IBCOMN",$J)
Q
;
HD ;Write Heading
S IBPAGE=IBPAGE+1
; IB*602/HN ; Add report headers to Excel Spreadsheets
I IBOUT="E" D W:($E(IOST,1,2)["C-") ! W "Patient Name^SSN^Age^DOB^Phone^Verified" Q
.W !,"Patients w/No Coverage Verification Date Report "_$$FMTE^XLFDT($$NOW^XLFDT,"Z")
.W !,"Verification Date Range: "_$$FMTE^XLFDT(IBBDT,"Z")_" to "_$$FMTE^XLFDT(IBEDT,"Z")
.W !," Filtered by: "_$S(IBAIB=1:"Patient Name",1:"Terminal Digit")_" Range: "_$S(IBRF="":"FIRST",1:IBRF)_" to "_$S(IBRL="zzzzzz":"LAST",1:IBRL) ;IB*752/DTG - sort to filter
.W !,"(* - Patient Deceased)"
; IB*602/HN end
W @IOF,!,"Patients w/No Coverage Verification Date Report",?50,$$FMTE^XLFDT($$NOW^XLFDT,"Z"),?70," Page ",IBPAGE
W !,?5,"Verification Date Range: "_$$FMTE^XLFDT(IBBDT,"Z")_" to "_$$FMTE^XLFDT(IBEDT,"Z")
;IB*743/TAZ - Modified Check of IBRF
;W !,?5," Sorted by: "_$S(IBAIB=1:"Patient Name",1:"Terminal Digit")_" Range: "_$S(IBRF="A":"FIRST",1:IBRF)_" to "_$S(IBRL="zzzzzz":"LAST",1:IBRL)
W !,?5," Filtered by: "_$S(IBAIB=1:"Patient Name",1:"Terminal Digit")_" Range: "_$S(IBRF="":"FIRST",1:IBRF)_" to "_$S(IBRL="zzzzzz":"LAST",1:IBRL) ;IB*752/DTG - sort to filter
W !,?20,"(* - Patient Deceased)"
W !,"Patient Name",?31,"SSN",?38,"Age",?43,"DOB",?55,"Phone",?70,"Verified"
W ! F IBX=1:1:79 W "="
Q
;
WRT ;Write data lines
N IBA,IBDFN,IBPT,X,Y S IBQUIT=0
S IBA="" F S IBA=$O(^TMP("IBCOMN",$J,IBA)) Q:(IBA="")!(IBQUIT=1) D
.S IBDFN=0 F S IBDFN=$O(^TMP("IBCOMN",$J,IBA,IBDFN)) Q:('IBDFN)!(IBQUIT=1) D
..S IBPT=$G(^TMP("IBCOMN",$J,IBA,IBDFN))
..;
..I ($Y+5)>IOSL,(IBOUT="R") D I IBQUIT=1 Q
...D ASK I IBQUIT=1 Q
...D HD
..;
..; Excel Output
..I IBOUT="E" W !,$P(IBPT,U,1)_U_$E($P(IBPT,U,1),1,1)_$P(IBPT,U,2)_U_$P(IBPT,U,3,6) Q
..; Report Output
..W !,$E($P(IBPT,U,1),1,30),?31,$E($P(IBPT,U,1),1,1),$P(IBPT,U,2),?38,$J($P(IBPT,U,3),3),?43,$P(IBPT,U,4),?55,$E($P(IBPT,U,5),1,15),?70,$P(IBPT,U,6)
..;
;I 'IBQUIT D ASK
I 'IBQUIT D EOR,ASK ;IB*752/DTG - EOR message
Q
;
ASK ; Ask to Continue with display
I $E(IOST,1,2)'["C-" Q
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="E" D ^DIR
I ($D(DIRUT))!($D(DUOUT)) S IBQUIT=1
Q
;
EOR ; End of report ;IB*752/DTG
W !," ** END OF REPORT **",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCOMN1 4497 printed Dec 13, 2024@02:18:25 Page 2
IBCOMN1 ;ALB/CMS - PATIENTS NO COVERAGE VERIFIED REPORT (CON'T);10-09-98
+1 ;;2.0;INTEGRATED BILLING;**103,528,602,743,752**;21-MAR-94;Build 20
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
BEG ; Entry to run Patients w/no Coverage Verification Report
+1 ; Input variables:
+2 ; IBAIB - Required. How to sort
+3 ; 1= Patient Name Range 2= Terminal Digit Range
+4 ;
+5 ; IBRF - Required. Name or Terminal Digit Range Start value
+6 ; IBRL - Required. Name or Terminal Digit Range Go to value
+7 ; IBBDT - Required. Begining Verification Date Range
+8 ; IBEDT - Required. Ending Verification Date Range
+9 ; IBOUT - Required. Output format
+10 ; "R"= report format "E"= Excel format
+11 ;
+12 NEW DFN,IBDT,IBGP,IBI,IBQUIT,IBPAGE,IBTMP,IBTD,IBX,VA,VADM,VAERR,X,Y
+13 ;IB*752/DTG - new variable for case insensitive
NEW IBVANM
SET IBVANM=""
+14 ;
+15 IF "^R^E^"'[(U_$GET(IBOUT)_U)
SET IBOUT="R"
+16 KILL ^TMP("IBCOMN",$JOB)
SET IBPAGE=0
SET IBQUIT=0
+17 SET IBDT=IBBDT
FOR
SET IBDT=$ORDER(^IBA(354,"AVDT",IBDT))
if ('IBDT)!(IBDT>IBEDT)
QUIT
Begin DoDot:1
+18 SET DFN=0
FOR
SET DFN=$ORDER(^IBA(354,"AVDT",IBDT,DFN))
if 'DFN
QUIT
Begin DoDot:2
+19 KILL VA,VADM,VAERR,VAPA
+20 DO DEM^VADPT
DO ADD^VADPT
+21 ;
+22 ; I Pt. name out of range quit
+23 SET VADM(1)=$PIECE($GET(VADM(1)),U,1)
IF VADM(1)=""
QUIT
+24 ;IB*752/DTG - case insensitive check
+25 SET IBVANM=$$UP^XLFSTR(VADM(1))
+26 ;I IBAIB=1,VADM(1)]IBRL Q
+27 ;I IBAIB=1,IBRF]VADM(1) Q
+28 IF IBAIB=1
IF $EXTRACT(IBVANM,1,$LENGTH(IBRLU))]IBRLU
QUIT
+29 IF IBAIB=1
IF IBRFU]$EXTRACT(IBVANM,1,$LENGTH(IBRFU))
QUIT
+30 ;
+31 ; I Terminal Digit out of range quit
+32 IF IBAIB=2
SET IBTD=$$TERMDG^IBCONS2(DFN)
IF (+IBTD>IBRL)!(IBRF>+IBTD)
QUIT
+33 ;
+34 ; Fix subscript error if terminal digit is null
+35 IF IBAIB=2
IF IBTD=""
SET IBTD=" "
+36 ;
+37 ; set data line, set global * if deceased
+38 ;S IBTMP=PT NAME^SSN^AGE^DOB^HOME PHONE^VERIFICATION NO COV
+39 SET IBTMP=$SELECT($GET(VADM(6)):"*",1:"")_VADM(1)_U_$PIECE($PIECE(VADM(2),U,2),"-",3)_U_+VADM(4)_U_$$FMTE^XLFDT(VADM(3),"5ZD")_U_$PIECE(VAPA(8),U,1)_U_$$FMTE^XLFDT(IBDT,"5ZD")
+40 SET ^TMP("IBCOMN",$JOB,$SELECT(IBAIB=2:IBTD,1:VADM(1)),DFN)=IBTMP
+41 ;
End DoDot:2
End DoDot:1
+42 ;
+43 IF '$DATA(^TMP("IBCOMN",$JOB))
DO HD
WRITE !!,"** NO RECORDS FOUND **"
DO EOR
DO ASK
GOTO QUEQ
+44 DO HD
DO WRT
+45 ;
QUEQ ; Exit clean-UP
+1 WRITE !
DO ^%ZISC
KILL IBTMP,IBAIB,IBOUT,IBRF,IBRL,VA,VAERR,VADM,VAPA,^TMP("IBCOMN",$JOB)
+2 QUIT
+3 ;
HD ;Write Heading
+1 SET IBPAGE=IBPAGE+1
+2 ; IB*602/HN ; Add report headers to Excel Spreadsheets
+3 IF IBOUT="E"
Begin DoDot:1
+4 WRITE !,"Patients w/No Coverage Verification Date Report "_$$FMTE^XLFDT($$NOW^XLFDT,"Z")
+5 WRITE !,"Verification Date Range: "_$$FMTE^XLFDT(IBBDT,"Z")_" to "_$$FMTE^XLFDT(IBEDT,"Z")
+6 ;IB*752/DTG - sort to filter
WRITE !," Filtered by: "_$SELECT(IBAIB=1:"Patient Name",1:"Terminal Digit")_" Range: "_$SELECT(IBRF="":"FIRST",1:IBRF)_" to "_$SELECT(IBRL="zzzzzz":"LAST",1:IBRL)
+7 WRITE !,"(* - Patient Deceased)"
End DoDot:1
if ($EXTRACT(IOST,1,2)["C-")
WRITE !
WRITE "Patient Name^SSN^Age^DOB^Phone^Verified"
QUIT
+8 ; IB*602/HN end
+9 WRITE @IOF,!,"Patients w/No Coverage Verification Date Report",?50,$$FMTE^XLFDT($$NOW^XLFDT,"Z"),?70," Page ",IBPAGE
+10 WRITE !,?5,"Verification Date Range: "_$$FMTE^XLFDT(IBBDT,"Z")_" to "_$$FMTE^XLFDT(IBEDT,"Z")
+11 ;IB*743/TAZ - Modified Check of IBRF
+12 ;W !,?5," Sorted by: "_$S(IBAIB=1:"Patient Name",1:"Terminal Digit")_" Range: "_$S(IBRF="A":"FIRST",1:IBRF)_" to "_$S(IBRL="zzzzzz":"LAST",1:IBRL)
+13 ;IB*752/DTG - sort to filter
WRITE !,?5," Filtered by: "_$SELECT(IBAIB=1:"Patient Name",1:"Terminal Digit")_" Range: "_$SELECT(IBRF="":"FIRST",1:IBRF)_" to "_$SELECT(IBRL="zzzzzz":"LAST",1:IBRL)
+14 WRITE !,?20,"(* - Patient Deceased)"
+15 WRITE !,"Patient Name",?31,"SSN",?38,"Age",?43,"DOB",?55,"Phone",?70,"Verified"
+16 WRITE !
FOR IBX=1:1:79
WRITE "="
+17 QUIT
+18 ;
WRT ;Write data lines
+1 NEW IBA,IBDFN,IBPT,X,Y
SET IBQUIT=0
+2 SET IBA=""
FOR
SET IBA=$ORDER(^TMP("IBCOMN",$JOB,IBA))
if (IBA="")!(IBQUIT=1)
QUIT
Begin DoDot:1
+3 SET IBDFN=0
FOR
SET IBDFN=$ORDER(^TMP("IBCOMN",$JOB,IBA,IBDFN))
if ('IBDFN)!(IBQUIT=1)
QUIT
Begin DoDot:2
+4 SET IBPT=$GET(^TMP("IBCOMN",$JOB,IBA,IBDFN))
+5 ;
+6 IF ($Y+5)>IOSL
IF (IBOUT="R")
Begin DoDot:3
+7 DO ASK
IF IBQUIT=1
QUIT
+8 DO HD
End DoDot:3
IF IBQUIT=1
QUIT
+9 ;
+10 ; Excel Output
+11 IF IBOUT="E"
WRITE !,$PIECE(IBPT,U,1)_U_$EXTRACT($PIECE(IBPT,U,1),1,1)_$PIECE(IBPT,U,2)_U_$PIECE(IBPT,U,3,6)
QUIT
+12 ; Report Output
+13 WRITE !,$EXTRACT($PIECE(IBPT,U,1),1,30),?31,$EXTRACT($PIECE(IBPT,U,1),1,1),$PIECE(IBPT,U,2),?38,$JUSTIFY($PIECE(IBPT,U,3),3),?43,$PIECE(IBPT,U,4),?55,$EXTRACT($PIECE(IBPT,U,5),1,15),?70,$PIECE(IBPT,U,6)
+14 ;
End DoDot:2
End DoDot:1
+15 ;I 'IBQUIT D ASK
+16 ;IB*752/DTG - EOR message
IF 'IBQUIT
DO EOR
DO ASK
+17 QUIT
+18 ;
ASK ; Ask to Continue with display
+1 IF $EXTRACT(IOST,1,2)'["C-"
QUIT
+2 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+3 SET DIR(0)="E"
DO ^DIR
+4 IF ($DATA(DIRUT))!($DATA(DUOUT))
SET IBQUIT=1
+5 QUIT
+6 ;
EOR ; End of report ;IB*752/DTG
+1 WRITE !," ** END OF REPORT **",!
+2 QUIT
