Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCOMC1

IBCOMC1.m

Go to the documentation of this file. 
  1. 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
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  Q
  1.  ;
  1. BEG ; Entry to run Identify Patients with/without Insurance Report
  1.  ; Input variables must exist:
  1.  ; IBAIB  - Required.    How to sort
  1.  ;          1= Patient Name Range      2= Terminal Digit Range
  1.  ; IBRF   - Required.  Name or Terminal Digit Range Start value
  1.  ; IBRL   - Required.  Name or Terminal Digit Range Go to value
  1.  ; IBAGEF - Optional.  Age start value or null
  1.  ; IBAGEL - Optional.  Age end value or null
  1.  ; IBBDT  - Required.  Last Treated Start Date
  1.  ; IBEDT  - Required.  Last Treated End Date
  1.  ;
  1.  ; IBSIN  - Required.   Include Insurance Company search
  1.  ;          1=Insurance Co. Range  2=Selected Ins. Co.  3=No Ins. Co.
  1.  ;          If IBSIN=2 then the $O(IBSIN(1-6))=selected companies
  1.  ; IBSINF - Optional.   Ins. Co. start Range or null
  1.  ; IBSINL - Optional.   Ins. Co. end Range or null
  1.  ; IBOUT  - Required.  Output format
  1.  ;          "R"= report format         "E"= Excel format
  1.  ;
  1.  N DFN,IBC,IBC0,IBDLT,IBGP,IBI,IBINS,IBINSV,IBPAGE,IBQUIT
  1.  N IBTMP,IBTD,IBX,IBXX,SDCNT,VA,VADM,VAERR,VAPA,X,Y
  1.  ;
  1.  N IBVANM,IBINSNAM,IBOK S (IBVANM,IBINSNAM,IBOK)=""  ;IB*752/DTG - new var's for case insensitive
  1.  ;
  1.  I "^R^E^"'[(U_$G(IBOUT)_U) S IBOUT="R"
  1.  K ^TMP("IBCOMC",$J) S IBPAGE=0,IBQUIT=0,IBINSV=""
  1.  ;
  1.  ;  Date Last Treated entered get DFN's
  1.  D DLT
  1.  ;
  1.  S DFN=0 F  S DFN=$O(^TMP("IBCOMC",$J,"DLT",DFN)) Q:'DFN  D
  1.  .;
  1.  .K IBINS S (IBTD,IBINSV,IBINS)=""
  1.  .;  I Terminal Digit out of range quit
  1.  .I IBAIB=2 S IBTD=$$TERMDG^IBCONS2(DFN) I (+IBTD>IBRL)!(IBRF>+IBTD) Q
  1.  .;
  1.  .; Fix subscript error if terminal digit is null
  1.  .I IBAIB=2,IBTD="" S IBTD=" "
  1.  .;
  1.  .K VA,VADM,VAERR,VAPA
  1.  .D DEM^VADPT,ADD^VADPT
  1.  .;
  1.  .;  I Pt. name out of range quit
  1.  .S VADM(1)=$P($G(VADM(1)),U,1) I VADM(1)="" Q
  1.  .;IB*752/DTG changing to uppercase, inclusive
  1.  .S IBVANM=$$UP^XLFSTR(VADM(1))
  1.  .;I IBAIB=1,VADM(1)]IBRL Q
  1.  .;I IBAIB=1,IBRF]VADM(1) Q
  1.  .I IBAIB=1,$E(IBVANM,1,$L(IBRLU))]IBRLU Q
  1.  .I IBAIB=1,IBRFU]$E(IBVANM,1,$L(IBRFU)) Q
  1.  .;
  1.  .;  I Age out of range quit
  1.  .I IBAGEF I (+VADM(4)<IBAGEF)!(+VADM(4)>IBAGEL) Q
  1.  .;
  1.  .;  Check Insurance
  1.  .S IBINSV=$G(^IBA(354,+DFN,60)) I IBSIN'=3,+IBINSV Q
  1.  .I IBSIN=3,IBINSV D SET Q
  1.  .;
  1.  .D ALL^IBCNS1(DFN,"IBINS",3)
  1.  .I IBSIN=3,$G(IBINS(0)) Q
  1.  .I IBSIN=3,'$G(IBINS(0)) D SET Q
  1.  .;
  1.  .S IBX=0 F  S IBX=$O(IBINS(IBX)) Q:'IBX  D
  1.  ..S IBC=IBINS(IBX,0)
  1.  ..S IBC0=$G(^DIC(36,+IBC,0))
  1.  ..;IB*752/DTG - change user's response to upper case
  1.  ..S IBINSNAM=$$UP^XLFSTR($P(IBC0,U,1))
  1.  ..;I IBSIN=1,$P(IBC0,U,1)]IBSINF,IBSINL]$P(IBC0,U,1) D SET Q
  1.  ..I IBSIN=1 S IBOK="" D  I IBOK=1 D SET Q
  1.  ...I $E(IBINSNAM,1,$L(IBSINFU))]IBSINFU,IBSINLU]$E(IBINSNAM,1,$L(IBSINLU)) S IBOK=1 Q
  1.  ...I $E(IBINSNAM,1,$L(IBSINLU))=IBSINLU S IBOK=1 Q
  1.  ...I $E(IBINSNAM,1,$L(IBSINFU))=IBSINFU&(IBSINLU]$E(IBINSNAM,1,$L(IBSINLU))) S IBOK=1 Q
  1.  ..;
  1.  ..;IB*752/DTG change from 6 insurances to many
  1.  ..;I IBSIN=2 F IBXX=1:1:6 I $G(IBSIN(IBXX)),+IBC=+IBSIN(IBXX) D SET
  1.  ..I IBSIN=2 S IBXX=0 F  S IBXX=$O(IBSIN(IBXX)) Q:'IBXX  I $G(IBSIN(IBXX)),+IBC=+IBSIN(IBXX) D SET
  1.  .;
  1.  ;IB*752/DTG - correct for EOR
  1.  ;I '$O(^TMP("IBCOMC",$J,0)) D HD^IBCOMC2 W !!,"** NO RECORDS FOUND **" D ASK^IBCOMC2 G QUEQ
  1.  I '$O(^TMP("IBCOMC",$J,0)) D  G QUEQ
  1.  .D HD^IBCOMC2 W !!,"** NO RECORDS FOUND **"
  1.  .D EOR,ASK^IBCOMC2
  1.  ;
  1.  D HD^IBCOMC2,WRT^IBCOMC2
  1.  I 'IBQUIT D EOR,ASK^IBCOMC2  ;IB*752/DTG EOR & pause
  1.  ;
  1. QUEQ ; Exit clean-UP
  1.  W ! D ^%ZISC K IBTMP,IBAIB,IBRF,IBRL,IBSIN,IBAGEF,IBAGEL,IBBDT,IBEDT,IBOUT,IBSINF,IBSINL,VA,VAERR,VADM,VAPA,^TMP("IBCOMC",$J)
  1.  K IBVANM,IBINSNAM,IBOK  ;IB*752/DTG - new var's for case insensitive
  1.  Q
  1.  ;
  1. EOR ; end of report IB*752/DTG
  1.  ;
  1.  W !,"** END OF REPORT **",!
  1.  Q
  1.  ;
  1. SET ;   set data line for global
  1.  ;S IBTMP(1)=PT NAME^SSN^AGE^DOB^CAT^DATE LAST VISIT
  1.  ;S IBTMP(2)=INSURANCE NAME^REIMBURSE?^GROUP NAME
  1.  ;           or Date Verified No Insurance on File and Patient Home Phone
  1.  ;
  1.  N IBTD,IBCAT
  1.  S IBTD(+$G(^TMP("IBCOMC",$J,"DLT",DFN,"INP")))="Inp "
  1.  S IBTD(+$G(^TMP("IBCOMC",$J,"DLT",DFN,"OUT")))="Out "
  1.  S IBTD=$O(IBTD(""),-1) S IBTD=IBTD_U_IBTD(IBTD)
  1.  S IBCAT=$P($$LST^DGMTU(DFN),U,4) S IBCAT=$S(IBCAT="C":"Yes",IBCAT="G":"GMT",1:"No")
  1.  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")
  1.  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)
  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)")
  1.  ;
  1.  ;   Set Global array
  1.  S ^TMP("IBCOMC",$J,1,$S(IBAIB=2:IBTD,1:VADM(1)),DFN)=IBTMP(1)
  1.  I IBSIN=3 S IBC=999999999
  1.  S ^TMP("IBCOMC",$J,1,$S(IBAIB=2:IBTD,1:VADM(1)),DFN,+IBC)=IBTMP(2)
  1. SETQ Q
  1.  ;
  1. DLT ;  Get DFN's for Date Last Treated Range
  1.  N IBCBK,IBDA,IBFIL,IBQUERY,IBVAL,IBX,X,Y K ^TMP("IBCOMC",$J,"DLT")
  1.  I (IBBDT="")!(IBEDT="") G DLTQ
  1.  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"
  1.  S IBVAL("BDT")=IBBDT,IBVAL("EDT")=IBEDT
  1.  ;
  1.  ;   get DFNs for date last seen outpatient
  1.  D SCAN^IBSDU("DATE/TIME",.IBVAL,IBFIL,IBCBK,1,0,"BACKWARD")
  1.  ;
  1.  ;   get DFNs for date last seen discharge date
  1.  S IBX=IBBDT F  S IBX=$O(^DGPM("ATT3",IBX)) Q:('IBX)!(IBX>IBEDT)  D
  1.  .S IBDA=0 F  S IBDA=$O(^DGPM("ATT3",IBX,IBDA)) Q:'IBDA  D
  1.  ..S ^TMP("IBCOMC",$J,"DLT",+$P($G(^DGPM(IBDA,0)),U,3),"OUT")=IBX
  1. DLTQ Q