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