IBCOMC1 ;ALB/CMS - IDENTIFY PT BY AGE WITH OR WITHOUT INSURANCE (CON'T);10-09-98
;;2.0;INTEGRATED BILLING;**103,183,528,752**;21-MAR-94;Build 20
;;Per VA Directive 6402, this routine should not be modified.
Q
;
BEG ; Entry to run Identify Patients with/without Insurance Report
; Input variables must exist:
; 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
; IBAGEF - Optional. Age start value or null
; IBAGEL - Optional. Age end value or null
; IBBDT - Required. Last Treated Start Date
; IBEDT - Required. Last Treated End Date
;
; IBSIN - Required. Include Insurance Company search
; 1=Insurance Co. Range 2=Selected Ins. Co. 3=No Ins. Co.
; If IBSIN=2 then the $O(IBSIN(1-6))=selected companies
; IBSINF - Optional. Ins. Co. start Range or null
; IBSINL - Optional. Ins. Co. end Range or null
; IBOUT - Required. Output format
; "R"= report format "E"= Excel format
;
N DFN,IBC,IBC0,IBDLT,IBGP,IBI,IBINS,IBINSV,IBPAGE,IBQUIT
N IBTMP,IBTD,IBX,IBXX,SDCNT,VA,VADM,VAERR,VAPA,X,Y
;
N IBVANM,IBINSNAM,IBOK S (IBVANM,IBINSNAM,IBOK)="" ;IB*752/DTG - new var's for case insensitive
;
I "^R^E^"'[(U_$G(IBOUT)_U) S IBOUT="R"
K ^TMP("IBCOMC",$J) S IBPAGE=0,IBQUIT=0,IBINSV=""
;
; Date Last Treated entered get DFN's
D DLT
;
S DFN=0 F S DFN=$O(^TMP("IBCOMC",$J,"DLT",DFN)) Q:'DFN D
.;
.K IBINS S (IBTD,IBINSV,IBINS)=""
.; 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=" "
.;
.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 changing to uppercase, 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 Age out of range quit
.I IBAGEF I (+VADM(4)<IBAGEF)!(+VADM(4)>IBAGEL) Q
.;
.; Check Insurance
.S IBINSV=$G(^IBA(354,+DFN,60)) I IBSIN'=3,+IBINSV Q
.I IBSIN=3,IBINSV D SET Q
.;
.D ALL^IBCNS1(DFN,"IBINS",3)
.I IBSIN=3,$G(IBINS(0)) Q
.I IBSIN=3,'$G(IBINS(0)) D SET Q
.;
.S IBX=0 F S IBX=$O(IBINS(IBX)) Q:'IBX D
..S IBC=IBINS(IBX,0)
..S IBC0=$G(^DIC(36,+IBC,0))
..;IB*752/DTG - change user's response to upper case
..S IBINSNAM=$$UP^XLFSTR($P(IBC0,U,1))
..;I IBSIN=1,$P(IBC0,U,1)]IBSINF,IBSINL]$P(IBC0,U,1) D SET Q
..I IBSIN=1 S IBOK="" D I IBOK=1 D SET Q
...I $E(IBINSNAM,1,$L(IBSINFU))]IBSINFU,IBSINLU]$E(IBINSNAM,1,$L(IBSINLU)) S IBOK=1 Q
...I $E(IBINSNAM,1,$L(IBSINLU))=IBSINLU S IBOK=1 Q
...I $E(IBINSNAM,1,$L(IBSINFU))=IBSINFU&(IBSINLU]$E(IBINSNAM,1,$L(IBSINLU))) S IBOK=1 Q
..;
..;IB*752/DTG change from 6 insurances to many
..;I IBSIN=2 F IBXX=1:1:6 I $G(IBSIN(IBXX)),+IBC=+IBSIN(IBXX) D SET
..I IBSIN=2 S IBXX=0 F S IBXX=$O(IBSIN(IBXX)) Q:'IBXX I $G(IBSIN(IBXX)),+IBC=+IBSIN(IBXX) D SET
.;
;IB*752/DTG - correct for EOR
;I '$O(^TMP("IBCOMC",$J,0)) D HD^IBCOMC2 W !!,"** NO RECORDS FOUND **" D ASK^IBCOMC2 G QUEQ
I '$O(^TMP("IBCOMC",$J,0)) D G QUEQ
.D HD^IBCOMC2 W !!,"** NO RECORDS FOUND **"
.D EOR,ASK^IBCOMC2
;
D HD^IBCOMC2,WRT^IBCOMC2
I 'IBQUIT D EOR,ASK^IBCOMC2 ;IB*752/DTG EOR & pause
;
QUEQ ; Exit clean-UP
W ! D ^%ZISC K IBTMP,IBAIB,IBRF,IBRL,IBSIN,IBAGEF,IBAGEL,IBBDT,IBEDT,IBOUT,IBSINF,IBSINL,VA,VAERR,VADM,VAPA,^TMP("IBCOMC",$J)
K IBVANM,IBINSNAM,IBOK ;IB*752/DTG - new var's for case insensitive
Q
;
EOR ; end of report IB*752/DTG
;
W !,"** END OF REPORT **",!
Q
;
SET ; set data line for global
;S IBTMP(1)=PT NAME^SSN^AGE^DOB^CAT^DATE LAST VISIT
;S IBTMP(2)=INSURANCE NAME^REIMBURSE?^GROUP NAME
; or Date Verified No Insurance on File and Patient Home Phone
;
N IBTD,IBCAT
S IBTD(+$G(^TMP("IBCOMC",$J,"DLT",DFN,"INP")))="Inp "
S IBTD(+$G(^TMP("IBCOMC",$J,"DLT",DFN,"OUT")))="Out "
S IBTD=$O(IBTD(""),-1) S IBTD=IBTD_U_IBTD(IBTD)
S IBCAT=$P($$LST^DGMTU(DFN),U,4) S IBCAT=$S(IBCAT="C":"Yes",IBCAT="G":"GMT",1:"No")
S IBTMP(1)=$S(+VADM(6):"*",1:"")_VADM(1)_U_"("_$E(VADM(1),1,1)_$P($P(VADM(2),U,2),"-",3)_")"_U_+VADM(4)_U_$P(VADM(3),U,2)_U_IBCAT_U_$P(IBTD,U,2)_$$FMTE^XLFDT(+IBTD,"5ZD")
I IBSIN=3 S IBTMP(2)=$S(+IBINSV:"No Coverage Verified: "_$$FMTE^XLFDT(+IBINSV,"5ZD"),1:"No Insurance on File.")_" Patient's Home Phone: "_$P(VAPA(8),U,1)
I IBSIN'=3 S IBTMP(2)=$P(IBC0,U,1)_U_$P(IBC0,U,2)_U_$S($P($G(IBINS(IBX,355.3)),U,3)]"":$P(IBINS(IBX,355.3),U,3),1:"(No Plan Name)")
;
; Set Global array
S ^TMP("IBCOMC",$J,1,$S(IBAIB=2:IBTD,1:VADM(1)),DFN)=IBTMP(1)
I IBSIN=3 S IBC=999999999
S ^TMP("IBCOMC",$J,1,$S(IBAIB=2:IBTD,1:VADM(1)),DFN,+IBC)=IBTMP(2)
SETQ Q
;
DLT ; Get DFN's for Date Last Treated Range
N IBCBK,IBDA,IBFIL,IBQUERY,IBVAL,IBX,X,Y K ^TMP("IBCOMC",$J,"DLT")
I (IBBDT="")!(IBEDT="") G DLTQ
S IBFIL="",IBCBK="I '$P(Y0,U,6),$P(Y0,U,12)=2,$P(Y0,U,7) S ^TMP(""IBCOMC"",$J,""DLT"",Y,""INP"")=+Y0"
S IBVAL("BDT")=IBBDT,IBVAL("EDT")=IBEDT
;
; get DFNs for date last seen outpatient
D SCAN^IBSDU("DATE/TIME",.IBVAL,IBFIL,IBCBK,1,0,"BACKWARD")
;
; get DFNs for date last seen discharge date
S IBX=IBBDT F S IBX=$O(^DGPM("ATT3",IBX)) Q:('IBX)!(IBX>IBEDT) D
.S IBDA=0 F S IBDA=$O(^DGPM("ATT3",IBX,IBDA)) Q:'IBDA D
..S ^TMP("IBCOMC",$J,"DLT",+$P($G(^DGPM(IBDA,0)),U,3),"OUT")=IBX
DLTQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCOMC1 5683 printed Oct 16, 2024@18:18:58 Page 2
IBCOMC1 ;ALB/CMS - IDENTIFY PT BY AGE WITH OR WITHOUT INSURANCE (CON'T);10-09-98
+1 ;;2.0;INTEGRATED BILLING;**103,183,528,752**;21-MAR-94;Build 20
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
BEG ; Entry to run Identify Patients with/without Insurance Report
+1 ; Input variables must exist:
+2 ; IBAIB - Required. How to sort
+3 ; 1= Patient Name Range 2= Terminal Digit Range
+4 ; IBRF - Required. Name or Terminal Digit Range Start value
+5 ; IBRL - Required. Name or Terminal Digit Range Go to value
+6 ; IBAGEF - Optional. Age start value or null
+7 ; IBAGEL - Optional. Age end value or null
+8 ; IBBDT - Required. Last Treated Start Date
+9 ; IBEDT - Required. Last Treated End Date
+10 ;
+11 ; IBSIN - Required. Include Insurance Company search
+12 ; 1=Insurance Co. Range 2=Selected Ins. Co. 3=No Ins. Co.
+13 ; If IBSIN=2 then the $O(IBSIN(1-6))=selected companies
+14 ; IBSINF - Optional. Ins. Co. start Range or null
+15 ; IBSINL - Optional. Ins. Co. end Range or null
+16 ; IBOUT - Required. Output format
+17 ; "R"= report format "E"= Excel format
+18 ;
+19 NEW DFN,IBC,IBC0,IBDLT,IBGP,IBI,IBINS,IBINSV,IBPAGE,IBQUIT
+20 NEW IBTMP,IBTD,IBX,IBXX,SDCNT,VA,VADM,VAERR,VAPA,X,Y
+21 ;
+22 ;IB*752/DTG - new var's for case insensitive
NEW IBVANM,IBINSNAM,IBOK
SET (IBVANM,IBINSNAM,IBOK)=""
+23 ;
+24 IF "^R^E^"'[(U_$GET(IBOUT)_U)
SET IBOUT="R"
+25 KILL ^TMP("IBCOMC",$JOB)
SET IBPAGE=0
SET IBQUIT=0
SET IBINSV=""
+26 ;
+27 ; Date Last Treated entered get DFN's
+28 DO DLT
+29 ;
+30 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("IBCOMC",$JOB,"DLT",DFN))
if 'DFN
QUIT
Begin DoDot:1
+31 ;
+32 KILL IBINS
SET (IBTD,IBINSV,IBINS)=""
+33 ; I Terminal Digit out of range quit
+34 IF IBAIB=2
SET IBTD=$$TERMDG^IBCONS2(DFN)
IF (+IBTD>IBRL)!(IBRF>+IBTD)
QUIT
+35 ;
+36 ; Fix subscript error if terminal digit is null
+37 IF IBAIB=2
IF IBTD=""
SET IBTD=" "
+38 ;
+39 KILL VA,VADM,VAERR,VAPA
+40 DO DEM^VADPT
DO ADD^VADPT
+41 ;
+42 ; I Pt. name out of range quit
+43 SET VADM(1)=$PIECE($GET(VADM(1)),U,1)
IF VADM(1)=""
QUIT
+44 ;IB*752/DTG changing to uppercase, inclusive
+45 SET IBVANM=$$UP^XLFSTR(VADM(1))
+46 ;I IBAIB=1,VADM(1)]IBRL Q
+47 ;I IBAIB=1,IBRF]VADM(1) Q
+48 IF IBAIB=1
IF $EXTRACT(IBVANM,1,$LENGTH(IBRLU))]IBRLU
QUIT
+49 IF IBAIB=1
IF IBRFU]$EXTRACT(IBVANM,1,$LENGTH(IBRFU))
QUIT
+50 ;
+51 ; I Age out of range quit
+52 IF IBAGEF
IF (+VADM(4)<IBAGEF)!(+VADM(4)>IBAGEL)
QUIT
+53 ;
+54 ; Check Insurance
+55 SET IBINSV=$GET(^IBA(354,+DFN,60))
IF IBSIN'=3
IF +IBINSV
QUIT
+56 IF IBSIN=3
IF IBINSV
DO SET
QUIT
+57 ;
+58 DO ALL^IBCNS1(DFN,"IBINS",3)
+59 IF IBSIN=3
IF $GET(IBINS(0))
QUIT
+60 IF IBSIN=3
IF '$GET(IBINS(0))
DO SET
QUIT
+61 ;
+62 SET IBX=0
FOR
SET IBX=$ORDER(IBINS(IBX))
if 'IBX
QUIT
Begin DoDot:2
+63 SET IBC=IBINS(IBX,0)
+64 SET IBC0=$GET(^DIC(36,+IBC,0))
+65 ;IB*752/DTG - change user's response to upper case
+66 SET IBINSNAM=$$UP^XLFSTR($PIECE(IBC0,U,1))
+67 ;I IBSIN=1,$P(IBC0,U,1)]IBSINF,IBSINL]$P(IBC0,U,1) D SET Q
+68 IF IBSIN=1
SET IBOK=""
Begin DoDot:3
+69 IF $EXTRACT(IBINSNAM,1,$LENGTH(IBSINFU))]IBSINFU
IF IBSINLU]$EXTRACT(IBINSNAM,1,$LENGTH(IBSINLU))
SET IBOK=1
QUIT
+70 IF $EXTRACT(IBINSNAM,1,$LENGTH(IBSINLU))=IBSINLU
SET IBOK=1
QUIT
+71 IF $EXTRACT(IBINSNAM,1,$LENGTH(IBSINFU))=IBSINFU&(IBSINLU]$EXTRACT(IBINSNAM,1,$LENGTH(IBSINLU)))
SET IBOK=1
QUIT
End DoDot:3
IF IBOK=1
DO SET
QUIT
+72 ;
+73 ;IB*752/DTG change from 6 insurances to many
+74 ;I IBSIN=2 F IBXX=1:1:6 I $G(IBSIN(IBXX)),+IBC=+IBSIN(IBXX) D SET
+75 IF IBSIN=2
SET IBXX=0
FOR
SET IBXX=$ORDER(IBSIN(IBXX))
if 'IBXX
QUIT
IF $GET(IBSIN(IBXX))
IF +IBC=+IBSIN(IBXX)
DO SET
End DoDot:2
+76 ;
End DoDot:1
+77 ;IB*752/DTG - correct for EOR
+78 ;I '$O(^TMP("IBCOMC",$J,0)) D HD^IBCOMC2 W !!,"** NO RECORDS FOUND **" D ASK^IBCOMC2 G QUEQ
+79 IF '$ORDER(^TMP("IBCOMC",$JOB,0))
Begin DoDot:1
+80 DO HD^IBCOMC2
WRITE !!,"** NO RECORDS FOUND **"
+81 DO EOR
DO ASK^IBCOMC2
End DoDot:1
GOTO QUEQ
+82 ;
+83 DO HD^IBCOMC2
DO WRT^IBCOMC2
+84 ;IB*752/DTG EOR & pause
IF 'IBQUIT
DO EOR
DO ASK^IBCOMC2
+85 ;
QUEQ ; Exit clean-UP
+1 WRITE !
DO ^%ZISC
KILL IBTMP,IBAIB,IBRF,IBRL,IBSIN,IBAGEF,IBAGEL,IBBDT,IBEDT,IBOUT,IBSINF,IBSINL,VA,VAERR,VADM,VAPA,^TMP("IBCOMC",$JOB)
+2 ;IB*752/DTG - new var's for case insensitive
KILL IBVANM,IBINSNAM,IBOK
+3 QUIT
+4 ;
EOR ; end of report IB*752/DTG
+1 ;
+2 WRITE !,"** END OF REPORT **",!
+3 QUIT
+4 ;
SET ; set data line for global
+1 ;S IBTMP(1)=PT NAME^SSN^AGE^DOB^CAT^DATE LAST VISIT
+2 ;S IBTMP(2)=INSURANCE NAME^REIMBURSE?^GROUP NAME
+3 ; or Date Verified No Insurance on File and Patient Home Phone
+4 ;
+5 NEW IBTD,IBCAT
+6 SET IBTD(+$GET(^TMP("IBCOMC",$JOB,"DLT",DFN,"INP")))="Inp "
+7 SET IBTD(+$GET(^TMP("IBCOMC",$JOB,"DLT",DFN,"OUT")))="Out "
+8 SET IBTD=$ORDER(IBTD(""),-1)
SET IBTD=IBTD_U_IBTD(IBTD)
+9 SET IBCAT=$PIECE($$LST^DGMTU(DFN),U,4)
SET IBCAT=$SELECT(IBCAT="C":"Yes",IBCAT="G":"GMT",1:"No")
+10 SET IBTMP(1)=$SELECT(+VADM(6):"*",1:"")_VADM(1)_U_"("_$EXTRACT(VADM(1),1,1)_$PIECE($PIECE(VADM(2),U,2),"-",3)_")"_U_+VADM(4)_U_$PIECE(VADM(3),U,2)_U_IBCAT_U_$PIECE(IBTD,U,2)_$$FMTE^XLFDT(+IBTD,"5ZD")
+11 IF IBSIN=3
SET IBTMP(2)=$SELECT(+IBINSV:"No Coverage Verified: "_$$FMTE^XLFDT(+IBINSV,"5ZD"),1:"No Insurance on File.")_" Patient's Home Phone: "_$PIECE(VAPA(8),U,1)
+12 IF IBSIN'=3
SET IBTMP(2)=$PIECE(IBC0,U,1)_U_$PIECE(IBC0,U,2)_U_$SELECT($PIECE($GET(IBINS(IBX,355.3)),U,3)]"":$PIECE(IBINS(IBX,355.3),U,3),1:"(No Plan Name)")
+13 ;
+14 ; Set Global array
+15 SET ^TMP("IBCOMC",$JOB,1,$SELECT(IBAIB=2:IBTD,1:VADM(1)),DFN)=IBTMP(1)
+16 IF IBSIN=3
SET IBC=999999999
+17 SET ^TMP("IBCOMC",$JOB,1,$SELECT(IBAIB=2:IBTD,1:VADM(1)),DFN,+IBC)=IBTMP(2)
SETQ QUIT
+1 ;
DLT ; Get DFN's for Date Last Treated Range
+1 NEW IBCBK,IBDA,IBFIL,IBQUERY,IBVAL,IBX,X,Y
KILL ^TMP("IBCOMC",$JOB,"DLT")
+2 IF (IBBDT="")!(IBEDT="")
GOTO DLTQ
+3 SET IBFIL=""
SET IBCBK="I '$P(Y0,U,6),$P(Y0,U,12)=2,$P(Y0,U,7) S ^TMP(""IBCOMC"",$J,""DLT"",Y,""INP"")=+Y0"
+4 SET IBVAL("BDT")=IBBDT
SET IBVAL("EDT")=IBEDT
+5 ;
+6 ; get DFNs for date last seen outpatient
+7 DO SCAN^IBSDU("DATE/TIME",.IBVAL,IBFIL,IBCBK,1,0,"BACKWARD")
+8 ;
+9 ; get DFNs for date last seen discharge date
+10 SET IBX=IBBDT
FOR
SET IBX=$ORDER(^DGPM("ATT3",IBX))
if ('IBX)!(IBX>IBEDT)
QUIT
Begin DoDot:1
+11 SET IBDA=0
FOR
SET IBDA=$ORDER(^DGPM("ATT3",IBX,IBDA))
if 'IBDA
QUIT
Begin DoDot:2
+12 SET ^TMP("IBCOMC",$JOB,"DLT",+$PIECE($GET(^DGPM(IBDA,0)),U,3),"OUT")=IBX
End DoDot:2
End DoDot:1
DLTQ QUIT
