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

IBCEMMR.m

Go to the documentation of this file.
  1. IBCEMMR ;ALB/ESG - IB MRA Report of Patients w/o Medicare WNR ; 03 Dec 2015 1:57 PM
  1. ;;2.0;INTEGRATED BILLING;**155,366,528,549**;21-MAR-94;Build 54
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ; Find patients with Medicare supplemental insurance or Medigap
  1. ; insurance (etc.) but who do not have MEDICARE (WNR) on file as
  1. ; one of their insurances.
  1. ;
  1. Q
  1. ;
  1. EN ; Entry Point
  1. ; ENDDATE - IB*2.0*549 End date for new filtering criteria
  1. ; STARTDT - IB*2.0*549 Start date for new filtering criteria
  1. ; IBCEEXCEL - IB*2.0*549 Enabling the capture of output and state report width to be 80 characters to a
  1. ; spreadsheet
  1. ;
  1. ; IB*2.0*549 New variables STARTDT, ENDDATE, IBCEEXCEL, STOP
  1. ; and STOP2.
  1. N ENDDATE,IBCEEXCEL,IBMSORT,STARTDT,STOP,STOP2
  1. ;
  1. ; IB*2.0*549 Add call to FILTER for new filtering criteria
  1. F D Q:STOP
  1. . S STOP=$$FILTER(.STARTDT,.ENDDATE)
  1. . ; IB*2.0*549 If STOP=1, exit outer loop (ABORTS from FILTER)
  1. . I 'STOP D
  1. . . F D Q:STOP!STOP2
  1. . . . D SORT
  1. . . . S STOP2='IBMSORT
  1. . . . ; IB*2.0*549 If no sort parameter, go back to top instead of
  1. . . . ; jumping to top
  1. . . . I 'STOP2 D
  1. . . . . ; IB*2.0*549 Add code to prompt for delimited file output and state report width to be 80 characters
  1. . . . . ; IB*2.0*549 If true, do SORT again
  1. . . . . I $$FORMAT(.IBCEEXCEL) D
  1. . . . . . ; IB*2.0*549 Add STARTDT, ENDDATE and IBCEEXCEL arguments
  1. . . . . . ; to call to DEVICE tag
  1. . . . . . D DEVICE(STARTDT,ENDDATE,IBCEEXCEL)
  1. . . . . . S STOP=2 ; Exit both loops / All input and state report width to be 80 characters good
  1. . . . . E D
  1. . . . . . S STOP2=2
  1. Q
  1. ;
  1. FILTER(STARTDT,ENDDATE) ; IB*2.0*549 New tag for getting
  1. ; start/end dates to filter by Last
  1. ; Appointment Date
  1. ; Input and state report width to be 80 characters/Output and state report width to be 80 characters (passed by reference)
  1. ; STARTDT - Start date for new filtering criteria
  1. ; ENDDATE - End date for new filtering criteria
  1. ; Return - 1 for continuing on in EN
  1. ; 0 for exiting EN
  1. ;
  1. N DIR,DIROUT,DIRUT,DTOUT,DUOUT,STOP
  1. W @IOF,!?20,"Patients Without MEDICARE (WNR) Insurance"
  1. W !
  1. W !?2,"This option finds patients who do not have active MEDICARE (WNR) insurance,"
  1. W !?2,"but who do have active insurance with a Plan Type of Medigap, Carve-Out, or"
  1. W !?2,"Medicare Secondary. In these cases, MEDICARE (WNR) should be primary."
  1. W !
  1. W !?2,"The insurances for all living patients will be analyzed, but"
  1. W !?2,"you can determine how this information will be sorted."
  1. W !!
  1. W !," Please enter Last Appointment Dates:"
  1. F D Q:STOP
  1. . D GETSTDT(.STARTDT)
  1. . I STARTDT?1.N D
  1. . . D GETENDDT(STARTDT,.ENDDATE)
  1. . . ; Exit loop (STOP=1) or redo START DATE
  1. . . S STOP=$S(ENDDATE?1.N:1,1:0)
  1. . E S STOP=2 ; Exit loop / EN needs to abort
  1. Q (STOP=2)
  1. ;
  1. GETSTDT(STARTDT) ; IB*2.0*549 Get start date for date filter
  1. ; Input and state report width to be 80 characters/Output and state report width to be 80 characters (Passed by reference)
  1. ; STARTDT - Start date for new filtering criteria
  1. ;
  1. N DIR,DIROUT,DIRUT,DTOUT,DUOUT
  1. S DIR(0)="D^:-NOW:EX"
  1. S DIR("A")=" Start DATE"
  1. S DIR("?",1)=" Please enter a valid date for filtering"
  1. S DIR("?",2)=" the Last Appointment Date. Future dates"
  1. S DIR("?")=" are not allowed."
  1. D ^DIR K DIR
  1. S STARTDT=Y
  1. Q
  1. ;
  1. GETENDDT(STARTDT,ENDDATE) ; IB*2.0*549 Get end date for date filter
  1. ; Input and state report width to be 80 characters
  1. ; STARTDT - Start date for new filtering criteria
  1. ; ENDDT - End date for new filtering criteria
  1. ;
  1. ; Output and state report width to be 80 characters (Passed by reference)
  1. ; ENDDT - End date for new filtering criteria
  1. ;
  1. N DIR,DIROUT,DIRUT,DTOUT,DUOUT
  1. S DIR(0)="DA^"_STARTDT_":-NOW:EX"
  1. S DIR("A")=" End DATE: "
  1. S DIR("B")=$$FMTE^XLFDT($$DT^XLFDT,"2DZ")
  1. S DIR("?",1)=" Please enter a valid date filtering the"
  1. S DIR("?",2)=" Last Appointment Date. This date must"
  1. S DIR("?",3)=" not precede the Start Date. Future"
  1. S DIR("?")=" dates are not allowed."
  1. D ^DIR K DIR
  1. S ENDDATE=Y
  1. Q
  1. ;
  1. FORMAT(IBCEEXCEL) ; IB*2.0*549 - capture the report format from
  1. ; the user (normal or CSV output and state report width to be 80 characters)
  1. ; Input and state report width to be 80 characters (passed by reference)
  1. ; IBCEEXCEL
  1. ; Output and state report width to be 80 characters
  1. ; IBCEEXCEL=0 for normal output and state report width to be 80 characters
  1. ; IBCEEXCEL=1 for CSV (comma separated values) for Excel
  1. ; Return
  1. ; 1 for good input and state report width to be 80 characters; or
  1. ; 0 for going back
  1. ;
  1. N DIR,DIROUT,DIRUT,DTOUT,DUOUT,STOP
  1. S IBCEEXCEL=""
  1. K DIR S DIR(0)="SA^E:Excel;R:Report"
  1. S DIR("A")=" (E)xcel Format or (R)eport Format: "
  1. S DIR("B")="Report"
  1. W ! D ^DIR
  1. S IBCEEXCEL=$S(Y="R":0,Y="E":1,1:Y)
  1. Q $S(IBCEEXCEL?1N:1,1:0)
  1. ;
  1. ; IB*2.0*549 Change sort to secondary sort and add documentation
  1. SORT ; Ask user how to sort the report
  1. ; (Secondary sort)
  1. ;
  1. N CH,DIR,DIROUT,DIRUT,DTOUT,DUOUT
  1. ; IB*2.0*549 Move IOF, title and description to FILTER tag
  1. S IBMSORT=""
  1. ; IB*2.0*549 Primary sort will be by Appointment Date and
  1. ; Secondary sort will not be by Appointment Date
  1. S CH="1:Patient Name;2:SSN - Last 4 Digits;3:Insurance Company;"
  1. S CH=CH_"4:Type of Plan"
  1. ;
  1. S DIR(0)="SO^"_CH
  1. S DIR("A")=" Please enter the secondary Sort Criteria"
  1. S DIR("B")="Patient Name"
  1. S DIR("?",1)="The primary sort for this report is the last appointment date. Please enter"
  1. S DIR("?")="a code from the list to identify the secondary sort."
  1. D ^DIR
  1. S:Y IBMSORT=Y
  1. SORTX ;
  1. Q
  1. ;
  1. COMPILE ; Entry point for both background and foreground task execution
  1. ;
  1. ; IB*2.0*549 - Document input and state report width to be 80 characters and output and state report width to be 80 characters
  1. ; Input and state report width to be 80 characters
  1. ; ZTQUEUED - Queued flag
  1. ; STARTDT - Start date for new filtering criteria
  1. ; ENDDT - End date for new filtering criteria
  1. ;
  1. ; Output and state report width to be 80 characters
  1. ; ZTSTOP - Flag for stopping routine
  1. ;
  1. ; IB*2.0*549 - Add DATA and SUBSCRIPT variables and alphabetize variables
  1. ; IB*2.0*549 - Enables filtering of dates, includes last verified date
  1. ; LSTVERDT - Last verified date
  1. ;
  1. N A,APPT,APTDTE,CNT,DATA,DFN,DPT,GRP,IBNEXT,INS,INSNM,LSTVERDT,MS,PLN
  1. N PLNTYP,PTNM,RTN,SORT,SSN,SUBSCRIPT,X
  1. S RTN="IBCEMMR"
  1. ; IB*2.0*528 - Add IBNEXT subscript to be initialized
  1. F X=RTN,"IBCEPT","IBSDNEXT","IBDPT","IBNEXT","IBLAST" K ^TMP($J,X)
  1. S DFN=" ",CNT=0
  1. F S DFN=$O(^DPT(DFN),-1) Q:'DFN!($G(ZTSTOP)) D
  1. . S CNT=CNT+1
  1. . I '$D(ZTQUEUED),CNT#500=0 U IO(0) W "." U IO
  1. . I $D(ZTQUEUED),CNT#500=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
  1. . I $P($G(^DPT(DFN,.35)),U,1) Q ; date of death
  1. . I '$$PTINS(DFN,.MS) Q ; eligible for report
  1. . S ^TMP($J,"IBNEXT",DFN)=""
  1. . S ^TMP($J,"IBLAST",DFN)=""
  1. . S ^TMP($J,"IBDPT",DFN)=""
  1. ;
  1. S X=$$NEXT^IBSDU("^TMP($J,""IBNEXT"",")
  1. S X=$$LAST^IBSDU("^TMP($J,""IBLAST"",")
  1. ;
  1. S DFN=0
  1. F S DFN=$O(^TMP($J,"IBDPT",DFN)) Q:'DFN!($G(ZTSTOP)) D
  1. . I '$D(ZTQUEUED),CNT#500=0 U IO(0) W "." U IO
  1. . I $D(ZTQUEUED),CNT#500=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
  1. . I '$$PTINS(DFN,.MS) ; get MS data
  1. . S DPT=$G(^DPT(DFN,0))
  1. . S PTNM=$P(DPT,U,1)
  1. . I PTNM="" S PTNM="~UNKNOWN"
  1. . S SSN=$E($P(DPT,U,9),6,99)_" "
  1. . S:SSN=" " SSN="~UNK"
  1. . ; IB*2.0*549 - Change default value to empty string
  1. . S (APPT,IBNEXT)=$G(^TMP($J,"IBNEXT",DFN))
  1. . I 'APPT S APPT=$G(^TMP($J,"IBLAST",DFN))
  1. . ;
  1. . ; IB*2.0*549 - Simplify $S assignment with $$GETAPDT
  1. . S APTDTE=$$GETAPDT(APPT,IBNEXT)
  1. . ; IB*2.0*549 - Delete non-day portion of APPT
  1. . S APPT=APPT\1
  1. . ; IB*2.0*549 FILTER BASED ON START DATE AND END DATE
  1. . Q:APTDTE="N/A"!(APPT<STARTDT)!(APPT>ENDDATE)
  1. . S A=0
  1. . F S A=$O(MS(A)) Q:'A D
  1. . . S INS=+$P(MS(A),U,1),GRP=+$P(MS(A),U,2)
  1. . . S PLN=+$P(MS(A),U,3)
  1. . . S INSNM=$P($G(^DIC(36,INS,0)),U,1)
  1. . . I INSNM="" S INSNM="~UNKNOWN"
  1. . . S PLNTYP=$P($G(^IBE(355.1,PLN,0)),U,1)
  1. . . I PLNTYP="" S PLNTYP="~UNKNOWN"
  1. . . ; IB*2.0*549 - Simplify $S assignment
  1. . . S SORT=$$GETIBMST(IBMSORT,PTNM,SSN,INSNM,PLNTYP)
  1. . . ; IB*2.0*549 Primary sort order by Last Appointment Date with
  1. . . ; most recent date at top. Data includes Last
  1. . . ; Verified Date.
  1. . . S LSTVERDT=$$GET1^DIQ(2.312,A_","_DFN_",",1.03,"I")
  1. . . S LSTVERDT=$$FMTE^XLFDT(LSTVERDT,"2DZ")
  1. . . S DATA=SSN_U_INSNM_U_PLNTYP_U_APTDTE_U_LSTVERDT
  1. . . S ^TMP($J,RTN,-APPT,SORT,PTNM,DFN,A)=DATA
  1. . . ; IB*2.0*549 Delete trailing quits
  1. ;
  1. I '$G(ZTSTOP) D PRINT ; print the report
  1. D ^%ZISC ; close the device
  1. ; IB*2.0*528 Add IBNEXT subscript to be cleaned up
  1. F SUBSCRIPT=RTN,"IBCEPT","IBSDNEXT","IBDPT","IBNEXT","IBLAST" K ^TMP($J,SUBSCRIPT)
  1. I $D(ZTQUEUED) S ZTREQ="@" ; purge the task record
  1. COMPX ;
  1. Q
  1. ;
  1. ; IB*2.0*549 Simplify setting of APTDTE from $S
  1. GETAPDT(APPT,IBNEXT) ; Get APTDTE from APPT/IBNEXT
  1. ; Input and state report width to be 80 characters
  1. ; APPT - Appointment date (external format)
  1. ; IBNEXT - Next appointment date
  1. ; Output and state report width to be 80 characters
  1. ; APTDTE - Appointment date (external format)
  1. ;
  1. N APTDTE
  1. D ; Simplification of $S
  1. . I APPT S APTDTE=$$FMTE^XLFDT($P(APPT,"."),"2Z") Q
  1. . I $L(IBNEXT) S APTDTE=IBNEXT Q
  1. . I $L(APPT) S APTDTE=APPT Q
  1. . S APTDTE="N/A"
  1. Q APTDTE
  1. ;
  1. ; IB*2.0*549 Simplify setting of SORT from $S
  1. GETIBMST(IBMSORT,PTNM,SSN,INSNM,PLNTYP) ; Get SORT from PTNM/SSN/INSNM/PLNTYP
  1. ; Input and state report width to be 80 characters
  1. ; IBMSORT - Sort choice index
  1. ; PTNM - Patient name
  1. ; SSN - SSN
  1. ; INSNM - Insurance name
  1. ; PLNTYP - Plan type
  1. ; Output and state report width to be 80 characters
  1. ; SORT - Secondary sort for report
  1. ;
  1. N SORT
  1. ; IB*2.0*549 Secondary sort does not include Last Appointment
  1. ; Date
  1. D ; Simplification of $S
  1. . I IBMSORT=1 S SORT=PTNM Q
  1. . I IBMSORT=2 S SORT=SSN Q
  1. . I IBMSORT=3 S SORT=INSNM Q
  1. . I IBMSORT=4 S SORT=PLNTYP Q
  1. . S SORT=PTNM
  1. Q SORT
  1. ;
  1. PRINT ; print the report to the device specified
  1. ; IB*2.0*549 APTDTE - Last appointment date (Primary sort criteria)
  1. ; Add APTDTE/DTOUT/DUOUT and alphabetize variables
  1. ; Add DF for data found
  1. N A,APTDTE,CRT,DATA,DF,DFN,DIR,DIROUT,DIRUT,DTOUT,DUOUT,IBX,MAXCNT,PAGECNT,PTNM
  1. N SORT,STOP,X,Y
  1. ; IB*2.0*549 APTDTE - Last appointment date (Primary sort criteria)
  1. S APTDTE=""
  1. ;
  1. I IOST["C-" S MAXCNT=IOSL-3,CRT=1
  1. E S MAXCNT=IOSL-6,CRT=0
  1. I IBCEEXCEL S IOSL=999999 ; IB*2.0*549 Long screen length for Excel
  1. ; output and state report width to be 80 characters
  1. S PAGECNT=0,STOP=0
  1. ;
  1. ; IB*2.0*549 Handle no data found in better fashion
  1. I '$D(^TMP($J,RTN)) D
  1. . S DF=0
  1. . D HEADER
  1. . W !!?5,"No Data Found"
  1. ;
  1. ; IB*2.0*549 for Excel CSV, display the header line first before looping
  1. ; Handle for instances where there is data found
  1. E D
  1. . S DF=1
  1. . I IBCEEXCEL W ! D HEADER Q:STOP
  1. . ;
  1. . D PRINT2(.STOP)
  1. Q:STOP
  1. W !!?30,"*** End of Report ***"
  1. ; IB*2.0*549 Where data is found
  1. I DF,CRT,'$D(ZTQUEUED) S DIR(0)="E" D ^DIR K DIR
  1. PRINTX ;
  1. Q
  1. ;
  1. PRINT2(STOP) ; Rest of Print tag
  1. ; IB*2.0*549 Put loops in new tag
  1. ; IB*2.0*549 Incorporate new primary sort criteria
  1. S APTDTE=""
  1. F S APTDTE=$O(^TMP($J,RTN,APTDTE)) Q:APTDTE="" D Q:STOP
  1. . S SORT=""
  1. . F S SORT=$O(^TMP($J,RTN,APTDTE,SORT)) Q:SORT="" D Q:STOP
  1. . . S PTNM=""
  1. . . F S PTNM=$O(^TMP($J,RTN,APTDTE,SORT,PTNM)) Q:PTNM="" D Q:STOP
  1. . . . S DFN=0
  1. . . . F S DFN=$O(^TMP($J,RTN,APTDTE,SORT,PTNM,DFN)) Q:'DFN D Q:STOP
  1. . . . . S A=0
  1. . . . . F S A=$O(^TMP($J,RTN,APTDTE,SORT,PTNM,DFN,A)) Q:'A D Q:STOP
  1. . . . . . S DATA=$G(^TMP($J,RTN,APTDTE,SORT,PTNM,DFN,A))
  1. . . . . . ; IB*2.0*549 for Excel output and state report width to be 80 characters, print a CSV format record
  1. . . . . . I IBCEEXCEL D EXCELN(PTNM,DATA) Q
  1. . . . . . ;
  1. . . . . . I $Y+1>MAXCNT!'PAGECNT D HEADER Q:STOP
  1. . . . . . ; IB*2.0*549 Add new field (Last Verified Date)
  1. . . . . . W !,$E(PTNM,1,16),?19,$P(DATA,U,1),?26,$E($P(DATA,U,2),1,17)
  1. . . . . . W ?45,$E($P(DATA,U,3),1,12),?59,$P(DATA,U,4),?69,$P(DATA,U,5)
  1. Q
  1. ;
  1. EXCELN(PTNM,DATA) ; IB*2.0*549 output and state report width to be 80 characters one Excel line
  1. ; Input and state report width to be 80 characters
  1. ; PTNM - Patient name
  1. ; DATA - Report data
  1. ;
  1. N IBZ
  1. S IBZ=$$CSV("",PTNM) ; patient name
  1. S IBZ=$$CSV(IBZ,$P(DATA,U,1)) ; SSN (Keeps leading zeroes)
  1. S IBZ=$$CSV(IBZ,$P(DATA,U,2)) ; insurance company
  1. S IBZ=$$CSV(IBZ,$P(DATA,U,3)) ; type of plan
  1. S IBZ=$$CSV(IBZ,$P(DATA,U,4)) ; appointment date
  1. S IBZ=$$CSV(IBZ,$P(DATA,U,5)) ; last verified date
  1. W !,IBZ
  1. Q
  1. ;
  1. ; IB*2.0*549 Add DIR/DIROUT/DIRUT/DTOUT/DUOUT
  1. ;
  1. N DIR,DIROUT,DIRUT,DTOUT,DUOUT,HDR,LIN,TAB
  1. S STOP=0
  1. ; ask screen user if they want to continue
  1. I CRT,PAGECNT>0,'$D(ZTQUEUED) D Q:STOP
  1. . I MAXCNT<51 F LIN=1:1:(MAXCNT-$Y) W !
  1. . S DIR(0)="E" D ^DIR K DIR
  1. . I 'Y S STOP=1 Q
  1. . ; IB*2.0*549 Delete trailing quits
  1. ;
  1. S PAGECNT=PAGECNT+1
  1. ; IB*2.0*549 *** Enable printing to delimited file ***
  1. I IBCEEXCEL D EXCELHD(ENDDATE,IBMSORT,STARTDT) Q ; IB*2.0*549 For Excel CSV format, display all headers
  1. ;
  1. W @IOF,!,"Patients Without MEDICARE (WNR) Insurance"
  1. S HDR="Page: "_PAGECNT
  1. S TAB=80-$L(HDR)-1
  1. W ?TAB,HDR
  1. ; IB*2.0*549 Appointment Date no longer Secondary Sort option
  1. W !,"Sorted by Appt, ",$S(IBMSORT=1:"Patient Name",IBMSORT=2:"SSN - Last 4 Digits",IBMSORT=3:"Insurance Company",IBMSORT=4:"Type of Plan",1:"Patient Name")
  1. S HDR=$$FMTE^XLFDT($$NOW^XLFDT,"1Z")
  1. S TAB=80-$L(HDR)-1
  1. W ?TAB,HDR
  1. W !,"Appointment Dates: ",$$CNVTDT(STARTDT)," - ",$$CNVTDT(ENDDATE)
  1. ; IB*2.0*549 Added blank line before column headers
  1. W !!,"Patient Name",?20,"SSN",?26,"Insurance Company"
  1. ; IB*2.0*549 Add new field (Last Verified Date)
  1. W ?45,"Type of Plan",?59,"ApptDate",?69,"LstVerDt"
  1. W !,$$RJ^XLFSTR("",80,"=")
  1. ;
  1. ; check for stop request
  1. I $D(ZTQUEUED),$$S^%ZTLOAD() D Q
  1. . S (ZTSTOP,STOP)=1
  1. . W !!!?5,"*** Report Halted by TaskManager Request ***"
  1. . ; IB*2.0*549 Delete trailing quits
  1. ;
  1. HEADERX ;
  1. Q
  1. ;
  1. CNVTDT(DATE) ; IB*2.0*549 Convert from VA internal date to MM/DD/YY
  1. N DAY,MON,YR
  1. S YR=(17+$E(DATE))_$E(DATE,2,3),MON=$E(DATE,4,5),DAY=$E(DATE,6,7)
  1. Q MON_"/"_DAY_"/"_YR
  1. ;
  1. EXCELHD(ENDDATE,IBMSORT,STARTDT) ; IB*2.0*549 print an Excel CSV header record (only 1 Excel CSV header
  1. ; should print for the whole report)
  1. ; IB*2.0*549 - Added code to enhance report header and simplify setting of IBMSORT
  1. N IBH,IBHDT,STR
  1. D NOW^%DTC
  1. S IBHDT=$$DAT2^IBOUTL($E(%,1,12))
  1. W !,"Patients Without MEDICARE (WNR) Insurance",?53,"Run On: ",IBHDT
  1. W !,"Sorted by Appt, "
  1. D
  1. . I IBMSORT=1 W "Patient Name" Q
  1. . I IBMSORT=2 W "SSN - Last 4 Digits" Q
  1. . I IBMSORT=3 W "Insurance Company" Q
  1. . I IBMSORT=4 W "Type of Plan" Q
  1. . W "Patient Name"
  1. W !,"Appointment Dates: ",$$CNVTDT(STARTDT)," - ",$$CNVTDT(ENDDATE)
  1. S IBH="Patient Name"
  1. F STR="SSN","Insurance Company","Type of Plan","ApptDate","LstVerDt" S IBH=IBH_U_STR
  1. W !!,IBH
  1. Q
  1. ;
  1. CSV(STRING,DATA) ; IB*2.0*549 build the Excel data string for CSV format
  1. ; Input and state report width to be 80 characters
  1. ; STRING - Excel data string being added on to
  1. ; DATA - Data to be added to string
  1. ; Output and state report width to be 80 characters
  1. ; STRING - Data string which was added to
  1. ;
  1. S DATA=$TR(DATA,U,"?")
  1. S STRING=$S(STRING="":DATA,1:STRING_U_DATA)
  1. Q STRING
  1. ;
  1. PTINS(DFN,MCRSUP) ; Function to determine if a patient should be
  1. ; included in this report or not.
  1. ; Input and state report width to be 80 characters: DFN - patient ien
  1. ; Output and state report width to be 80 characters: Function value is either 0 (don't include) or 1 (include)
  1. ; MCRSUP array pass by reference
  1. ; MCRSUP(seq) = [1] insurance co ien pointer to file 36
  1. ; [2] group pointer to file 355.3
  1. ; [3] type of plan pointer to file 355.1
  1. ;
  1. ;IB*2.0*549 Abbreviate NEW to N and alphabetize variables
  1. N A,GP,IBGRP,IBINS,INCLUDE,INS,MCRWNR,MCRZ,PLABBR,TP
  1. S INCLUDE=0 KILL MCRSUP
  1. I '$G(DFN) G PTINSX
  1. I '$D(^DPT(DFN)) G PTINSX
  1. D ALLWNR^IBCNS1(DFN,"INS",DT)
  1. S A=0,(MCRWNR,MCRZ)=0
  1. F S A=$O(INS(A)) Q:'A D Q:MCRWNR
  1. . S IBINS=$P($G(INS(A,0)),U,1)
  1. . S IBGRP=$P($G(INS(A,0)),U,18)
  1. . I $$MCRWNR^IBEFUNC(IBINS) S MCRWNR=1 Q ; Medicare WNR on file
  1. . S GP=$G(INS(A,355.3)) ; group/plan info
  1. . S TP=$P(GP,U,9),PLABBR="" ; type of plan pointer
  1. . I TP S PLABBR=$P($G(^IBE(355.1,TP,0)),U,2) ; plan abbreviation
  1. . I '$F(".MG.MS.COUT.","."_PLABBR_".") Q ; check plan
  1. . S MCRZ=1 ; Medicare other on file
  1. . S MCRSUP(A)=IBINS_U_IBGRP_U_TP
  1. . ; IB*2.0*549 Delete trailing quits
  1. ;
  1. ; If Medicare Other was found, but no Medicare WNR, then include it
  1. I MCRZ,'MCRWNR S INCLUDE=1
  1. ;
  1. PTINSX ;
  1. I 'INCLUDE K MCRSUP
  1. Q INCLUDE
  1. ;
  1. ; IB*2.0*549 Add STARTDT, ENDDATE and IBCEEXCEL arguments to pass to
  1. ; DEVICE tag
  1. DEVICE(STARTDT,ENDDATE,IBCEEXCEL) ; This procedure displays a warning message
  1. ; AND prompts for the device on which to
  1. ; print the report.
  1. ;
  1. ;IB*2.0*549 Add DIR/DIROUT/DIRUT/DTOUT/DUOUT
  1. N DIR,DIROUT,DIRUT,DTOUT,DUOUT,POP,ZTDESC,ZTRTN,ZTSAVE
  1. ; IB*2.0*549 Allow for CSV output and state report width to be 80 characters
  1. I 'IBCEEXCEL D
  1. . W !!,"This report is 80 characters wide. "
  1. . W "Please choose an appropriate device.",!
  1. E D
  1. . W !!,"For CSV output and state report width to be 80 characters, turn logging or capture on now."
  1. . W !,"To avoid undesired wrapping of the data saved to the file,"
  1. . W !,"please enter ""0;256;99999"" at the ""DEVICE:"" prompt.",!
  1. ;
  1. W *7,!!!?14,"*** WARNING ***"
  1. W !?2,"This report takes a long time to compile!"
  1. W !!?2,"The active insurance coverage for all living patients is analyzed."
  1. W !!?2,"It is recommended that you queue this report to the background and"
  1. W !?2,"run it after hours or on the weekend."
  1. W !!?2,"This report is 80 characters wide."
  1. W !
  1. ;
  1. S ZTRTN="COMPILE^IBCEMMR"
  1. S ZTDESC="Patients without MEDICARE (WNR) Insurance"
  1. S ZTSAVE("IBMSORT")=""
  1. ; IB*2.0*549 Add code to save STARTDT, ENDDATE and IBCEEXCEL
  1. S ZTSAVE("STARTDT")=""
  1. S ZTSAVE("ENDDATE")=""
  1. S ZTSAVE("IBCEEXCEL")=""
  1. ; IB*2.0*549 Enable report to choose a file in delimited format
  1. D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,"QM",1)
  1. I $G(ZTSK) D
  1. . W !!,"Report compilation has started with task# ",ZTSK,".",!
  1. . S DIR(0)="E" D ^DIR
  1. DEVICEX ;
  1. Q
  1. ;