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

FBARCHR0.m

Go to the documentation of this file. 
  1. FBARCHR0 ; HINOIFO/BNT - ARCH Reports ; 05/09/11 5:30pm
  1.  ;;3.5;FEE BASIS;**130**;JAN 30, 1995;Build 13
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;Integration Agreements:
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. SELSMDET(DFLT) ; Display (S)ummary or (D)etail Format
  1.  ; Input Variable -> DFLT = 1 Summary
  1.  ;                          2 Detail
  1.  ;                          
  1.  ; Return Value ->   1 = Summary
  1.  ;                   0 = Detail
  1.  ;                   ^ = Exit
  1.  ;
  1.  N DIR,DIRUT,DTOUT,DUOUT,X,Y
  1.  S DFLT=$S($G(DFLT)=1:"Summary",$G(DFLT)=0:"Detail",1:"Detail")
  1.  S DIR(0)="S^S:Summary;D:Detail",DIR("A")="Display (S)ummary or (D)etail Format",DIR("B")=DFLT
  1.  D ^DIR
  1.  I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
  1.  S Y=$S(Y="S":1,Y="D":0,1:Y)
  1.  Q Y
  1.  ;
  1. SELEXCEL() ; - Returns whether to capture data for Excel report.
  1.  ; Output: EXCEL = 1 - YES (capture data) / 0 - NO (DO NOT capture data)
  1.  ;
  1.  N EXCEL,DIR,DIRUT,DTOUT,DUOUT,DIROUT
  1.  ;
  1.  S DIR(0)="Y",DIR("B")="NO",DIR("T")=DTIME W !
  1.  S DIR("A")="Do you want to capture report data for an Excel document"
  1.  S DIR("?")="^D HEXC^FBARCHR0"
  1.  D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q "^"
  1.  K DIROUT,DTOUT,DUOUT,DIRUT
  1.  S EXCEL=0 I Y S EXCEL=1
  1.  ;
  1.  ;Display Excel display message
  1.  I EXCEL=1 D EXMSG
  1.  ;
  1.  Q EXCEL
  1.  ;
  1. SELPAT(DFLT) ; - Returns either a Fee Basis Patient IEN or 0 for All patients
  1.  N DIR,DIRUT,DTOUT,DUOUT,X,Y
  1.  S DFLT=$S($G(DFLT)=1:"One Patient",$G(DFLT)=0:"All Patients",1:"All Patients")
  1.  S DIR(0)="S^P:One Patient;A:All Patients",DIR("A")="Display One (P)atient or (A)ll Patients",DIR("B")=DFLT
  1.  D ^DIR
  1.  I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
  1.  S Y=$S(Y="P":1,Y="A":0,1:Y)
  1.  I Y D
  1.  . N DIR,DIRUT,DTOUT,DUOUT
  1.  . ;Prompt to select FEE BASIS PATIENT file entry
  1.  . S DIR(0)="P^161:EMZ",DIR("S")="I $D(^FBAAA(Y,""ARCHFEE"",0))"
  1.  . D ^DIR I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
  1.  . I +Y S Y=+Y
  1.  Q Y
  1.  ;            
  1. SELDATE(DFLT) ; Select Date Range
  1.  ; Input Variable -> DFLT = 1 - ARCH Eligibility Date
  1.  ;                          0 - All Dates
  1.  ;
  1.  ; Return Value -> P1^P2
  1.  ; 
  1.  ;           where P1 = From Date
  1.  ;                    = ^ Exit
  1.  ;                 P2 = To Date
  1.  ;                    = blank for Exit
  1.  ;
  1.  N DIR,DIRUT,DTOUT,DUOUT,VAL,X,Y
  1.  S DFLT=$S($G(DFLT)=1:"ARCH Eligibility Date",$G(DFLT)=0:"All",1:"All")
  1.  S DIR(0)="S^D:ARCH Eligibility Date;A:All",DIR("A")="Select a beginning ARCH Eligibility (D)ate or (A)ll",DIR("B")=DFLT
  1.  D ^DIR
  1.  I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
  1.  S Y=$S(Y="D":1,Y="A":0,1:Y)
  1.  I Y'=1 Q Y
  1.  ;
  1.  S VAL="",DIR(0)="DA^:DT:EX",DIR("A")="Beginning ARCH Eligibility Date: ",DIR("B")="SEP 30, 2010"
  1.  W ! D ^DIR
  1.  ;
  1.  ;Check for "^", timeout, or blank entry
  1.  I ($G(DUOUT)=1)!($G(DTOUT)=1)!($G(X)="") S VAL="^"
  1.  ;
  1.  I VAL="" D
  1.  .S $P(VAL,U)=Y
  1.  .S DIR(0)="DA^"_VAL_":DT:EX",DIR("A")="   Ending ARCH Eligibility Date: ",DIR("B")="T"
  1.  .D ^DIR
  1.  .;
  1.  .;Check for "^", timeout, or blank entry
  1.  .I ($G(DUOUT)=1)!($G(DTOUT)=1)!($G(X)="") S VAL="^" Q
  1.  .;
  1.  .;Define Entry
  1.  .S $P(VAL,U,2)=Y
  1.  ;
  1.  Q VAL
  1.  ;
  1. SELELIG(DFLT) ; Select ARCH Eligibility Status
  1.  ; Input Variable -> DFLT = 0 - NO patient is not ARCH eligible
  1.  ;                          1 - YES patient is ARCH eligible
  1.  ;                          2 - BOTH
  1.  ;
  1.  ; Return Value ->   0 - NO patient is not ARCH eligible
  1.  ;                   1 - YES patient is ARCH eligible
  1.  ;                   2 - BOTH
  1.  ;                   ^ - EXIT
  1.  ;
  1.  N DIR,DIRUT,DTOUT,DUOUT,X,Y
  1.  S DFLT=$S($G(DFLT)=0:"NO",$G(DFLT)=1:"YES",1:"BOTH")
  1.  S DIR(0)="S^Y:YES - Patient is ARCH Eligible;N:NO  - Patient is NOT ARCH Eligible;B:BOTH",DIR("A")="Which ARCH Eligibility Status should display (Y/N/B)",DIR("B")=DFLT
  1.  D ^DIR
  1.  I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
  1.  S Y=$S(Y="N":0,Y="Y":1,Y="B":2,1:Y)
  1.  Q Y
  1.  ;
  1. SELELDET(DFLT) ; Select ARCH Eligibility Determination
  1.  ; Input Variable -> DFLT = 0 - CAC
  1.  ;                          1 - SAS DB Update
  1.  ;                          2 - All
  1.  ;
  1.  ; Return Value ->   New Person File IEN of CAC
  1.  ;                   -1 - SAS DB Update
  1.  ;                   0 - All
  1.  ;                   ^ - EXIT
  1.  ;
  1.  N DIR,DIRUT,DTOUT,DUOUT,X,Y
  1.  S DFLT=$S($G(DFLT)=0:"U",$G(DFLT)=1:"N",1:"A")
  1.  S DIR(0)="S^C:Project ARCH CAC;S:SAS DB Update;A:All",DIR("A")="Select ARCH Elig Determination (C)AC, (S)AS DB update or (A)LL",DIR("B")=DFLT
  1.  D ^DIR
  1.  I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
  1.  S Y=$S(Y="C":1,Y="S":0,Y="A":-1,1:Y)
  1.  I Y=1 D
  1.  . N DIR,DIRUT,DTOUT,DUOUT
  1.  . ;Prompt to select NEW PERSON file entry. Screen on ELIGIBILITY SOURCE
  1.  . S DIR(0)="P^200:EMZ",DIR("S")="I $D(^FBAAA(""ARCHSRC"",Y))"
  1.  . S DIR("A")="Select Project ARCH CAC"
  1.  . D ^DIR I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
  1.  . S Y=+Y
  1.  Q Y
  1.  ;
  1. SELJUST() ; Select the ARCH Justification Reason
  1.  ; Return Value ->   FEE BASIS PROJECT ARCH JUSTIFICATION file #161.35 IEN
  1.  ;
  1.  N FBJUST,IEN,X,CNT,FBJAR,DIR,DTOUT,DUOUT,Y
  1.  S (FBJUST,X,CNT)=0
  1.  W !!,"     Project ARCH Justification Reasons",!
  1.  F  S FBJUST=$O(^FBAA(161.35,"C",FBJUST)) Q:FBJUST=""  D
  1.  . S IEN=$O(^FBAA(161.35,"C",FBJUST,0))
  1.  . Q:$P(^FBAA(161.35,IEN,0),U,2)'=1
  1.  . S CNT=CNT+1
  1.  . S FBJAR(CNT)=FBJUST_U_IEN
  1.  F  S X=$O(FBJAR(X)) Q:X=""  D
  1.  . W !,?5,X
  1.  . I $L($P(FBJAR(X),U))>69 D
  1.  . . ; Handle the line breaks and hyphenate the word in the right spot
  1.  . . I $E($P(FBJAR(X),U),70)'=" " D  Q
  1.  . . . W ?10,$E($P(FBJAR(X),U),1,69),"-"
  1.  . . . W !,?10,$E($P(FBJAR(X),U),70,$L($P(FBJAR(X),U)))
  1.  . . W ?10,$E($P(FBJAR(X),U),1,70)
  1.  . . W !,?10,$E($P(FBJAR(X),U),71,$L($P(FBJAR(X),U)))
  1.  W !
  1.  S DIR(0)="N^1:"_CNT,DIR("A")="Select ARCH Justification" D ^DIR
  1.  I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^" Q Y
  1.  W "  ",$P(FBJAR(Y),U),!
  1.  Q $P(FBJAR(Y),U,2)
  1.  ;
  1. HEXC ; - 'Do you want to capture data...' prompt
  1.  W !!,"      Enter:  'Y'    -  To capture detail report data to transfer"
  1.  W !,"                        to an Excel document"
  1.  W !,"              '<CR>' -  To skip this option"
  1.  W !,"              '^'    -  To quit this option"
  1.  Q
  1.  ;
  1.  ;Display the message about capturing to an Excel file format
  1.  ; 
  1. EXMSG ;
  1.  W !!?5,"Before continuing, please set up your terminal to capture the"
  1.  W !?5,"detail report data. On some terminals, this can  be  done  by"
  1.  W !?5,"clicking  on the 'Tools' menu above, then click  on  'Capture"
  1.  W !?5,"Incoming  Data' to save to  Desktop. This  report  may take a"
  1.  W !?5,"while to run."
  1.  W !!?5,"Note: To avoid  undesired  wrapping of the data  saved to the"
  1.  W !?5,"      file, please enter '0;256;999' at the 'DEVICE:' prompt.",!
  1.  Q
  1.  ;
  1.  ;Screen Pause 1
  1.  ;
  1.  ; Return variable - FBQ = 0 Continue
  1.  ;                          2 Quit
  1. PAUSE N X
  1.  U IO(0) W !!,"Press RETURN to continue, '^' to exit:"
  1.  R X:$G(DTIME) S:'$T X="^" S:X["^" FBQ=2
  1.  U IO
  1.  Q
  1.  ;
  1.  ;Screen Pause 2
  1.  ;
  1.  ; Return variable - FBQ = 0 Continue
  1.  ;                         2 Quit
  1. PAUSE2 N X
  1.  U IO(0) W !!,"Press RETURN to continue:"
  1.  R X:$G(DTIME) S:'$T X="^" S:X["^" FBQ=2
  1.  U IO
  1.  Q
  1.  ;
  1. CHKKEY(KEY) ; Check if user holds the appropriate security key
  1.  ; Return 1 if user holds key, 0 if not and display message
  1.  Q:KEY']"" 0
  1.  I $D(^XUSEC(KEY,DUZ)) Q 1
  1.  W !,"You must hold the "_KEY_" Security Key in order to continue."
  1.  D PAUSE2
  1.  Q 0
  1.  ;
  1. REPORT(REF,FBEXCEL,FBSCR,FBRPTNAM,FBPAT,FBBEGDT,FBENDDT,FBELIG,FBELDET,FBSUMDET,FBPAGE) ; Display the report
  1.  N DFN,ELIGDT,DETUSR,FB11,ELIGIND,FBARCH0,FBCNT
  1.  N NP,FBLOCNT,FBNCNT,FBNELCNT,FBNPAT,FBELPAT
  1.  S (FBLOCNT,FBNCNT,FBNELCNT,FBCNT)=0
  1.  D HDR(FBRPTNAM,.FBPAGE)
  1.  I '$D(@REF) W !,"No data meets the criteria." G XREPORT
  1.  ;
  1.  S DFN="" F  S DFN=$O(@REF@(DFN)) Q:DFN=""  D  Q:FBQ
  1.  . Q:'$D(^DPT(DFN))
  1.  . ; Check the patient filter
  1.  . I FBPAT Q:DFN'=FBPAT
  1.  . S FBNPAT=1
  1.  . S ELIGDT="" F  S ELIGDT=$O(@REF@(DFN,ELIGDT)) Q:ELIGDT=""  D  Q:FBQ
  1.  . . ; Check the date filters
  1.  . . I FBBEGDT,ELIGDT<FBBEGDT Q
  1.  . . S FB11="" F  S FB11=$O(@REF@(DFN,ELIGDT,FB11)) Q:FB11=""  D  Q:FBQ
  1.  . . . S FBARCH0=^FBAAA(DFN,"ARCHFEE",FB11,0)
  1.  . . . S ELIGIND=$P(FBARCH0,U,2)
  1.  . . . S DETUSR=$S($P(FBARCH0,U,3)]"":$P(^VA(200,$P(FBARCH0,U,3),0),U),1:"SAS DB UPDATE")
  1.  . . . ; Check the Eligibility filter
  1.  . . . I FBELIG'=2,FBELIG'=ELIGIND Q
  1.  . . . ; Check Determination Source filter
  1.  . . . I FBELDET>0,FBELDET'=$P(FBARCH0,U,3) Q
  1.  . . . I FBELDET=0,$P(FBARCH0,U,3)]"" Q
  1.  . . . ; Set eligibility counter
  1.  . . . S FBELPAT(DFN)=$S((ELIGIND)&($P(FBARCH0,U,3)]""):1,(ELIGIND)&($P(FBARCH0,U,3)=""):2,1:0)
  1.  . . . I FBNPAT S FBCNT=FBCNT+1
  1.  . . . S NP=$$CHKP(1) Q:FBQ
  1.  . . . I 'FBSUMDET D
  1.  . . . . D WRLINE1(FBEXCEL,$S(FBNPAT:FBCNT,1:""),$P(^DPT(DFN,0),U),ELIGDT,ELIGIND,DETUSR)
  1.  . . . . I $P(FBARCH0,U,4)]"" D WRLINE2(FBEXCEL,$P(FBARCH0,U,4))
  1.  . . . . I $P(FBARCH0,U,5)]"" D WRLINE3(FBEXCEL,$P(FBARCH0,U,5))
  1.  . . . ; Reset FBNPAT to not print the ID if same patient
  1.  . . . S FBNPAT=0
  1.  Q:FBQ
  1.  ; Get the total eligible patients
  1.  N DFN S DFN="" F  S DFN=$O(FBELPAT(DFN)) Q:DFN=""  D
  1.  . ; Get locally defined eligible patients
  1.  . I FBELPAT(DFN)=1 S FBLOCNT=FBLOCNT+1 Q
  1.  . ; Get nationally defined eligible patients
  1.  . I FBELPAT(DFN)=2 S FBNCNT=FBNCNT+1 Q
  1.  . ; Get locally defined patients changed to Not Eligible
  1.  . S FBNELCNT=FBNELCNT+1
  1.  W !
  1.  I (FBELIG=1)!(FBELIG=2) W !,"Total Nationally Determined Project ARCH Eligible Patients:  "_FBNCNT
  1.  I (FBELIG=1)!(FBELIG=2) W !,"Total Locally Determined Project ARCH Eligible Patients:  "_FBLOCNT
  1.  I (FBELIG=0)!(FBELIG=2) W !,"Total Locally Determined Eligible changed to Not Eligible:  "_FBNELCNT
  1.  Q
  1.  ;
  1. WRLINE1(FBEXCEL,ID,PATIENT,ELIGDT,ELIGIND,DETERM) ; Write Line 1 of report
  1.  I FBEXCEL W !,ID_U_PATIENT_U_$$FMTE^XLFDT(ELIGDT)_U_$S(ELIGIND=1:"YES",1:"NO")_U_DETERM Q
  1.  ;
  1.  W !,ID,?8,PATIENT,?35,$$FMTE^XLFDT(ELIGDT),?51,$S(ELIGIND=1:"YES",1:"NO"),?64,DETERM
  1.  Q
  1.  ;
  1. WRLINE2(FBEXCEL,FBJUST) ; Write Line 2 of report
  1.  I FBEXCEL W U_$P(^FBAA(161.35,FBJUST,0),U) Q
  1.  ;
  1.  W !,?10,$P(^FBAA(161.35,FBJUST,0),U)
  1.  Q
  1.  ;
  1. WRLINE3(FBEXCEL,FBMILE) ; Write Line 3 of report
  1.  I FBEXCEL W U_FBMILE Q
  1.  ;
  1.  W !,?12,FBMILE
  1.  Q
  1.  ;
  1.  ;Check for End of Page
  1.  ; Input variables -> FBLINES -> Number of lines from bottom
  1.  ;                    FBEXCEL -> 1 - Print to Excel/0 Regular Display
  1.  ; Output variable -> FBDATA  -> 0 -> New screen, no data displayed yet
  1.  ;                               1 -> Data displayed on current screen
  1. CHKP(FBLINES) Q:$G(FBEXCEL) 0
  1.  S FBLINES=FBLINES+1
  1.  I $G(FBSCR) S FBLINES=FBLINES+2
  1.  I $G(FBSCR),'$G(FBDATA) S FBDATA=1 Q 0
  1.  S FBDATA=1
  1.  I $Y>(IOSL-FBLINES) D:$G(FBSCR) PAUSE Q:$G(FBQ) 0 D HDR(FBRPTNAM,.FBPAGE) Q 1
  1.  Q 0
  1.  ;
  1.  ;Print one line of characters
  1. ULINE(X) N I
  1.  W ! F I=1:1:80 W $G(X,"-")
  1.  Q
  1.  ;
  1. HDR(FBRPTNAM,FBPAGE) ;
  1.  ;Display Excel Header
  1.  I FBEXCEL D EXHDR Q
  1.  ;
  1.  ; Define FBDATA - Tells whether data has been displayed for a screen
  1.  S FBDATA=0
  1.  S FBPAGE=$G(FBPAGE)+1
  1.  W @IOF
  1.  W FBRPTNAM_" ("_$S(FBSUMDET=1:"SUMMARY",1:"DETAIL")_" REPORT)"
  1.  W $$RJ("Page: "_FBPAGE,30)
  1.  W !,"Print Date: "_$G(FBNOW)
  1.  I +FBBEGDT W !,"Report Date From "_$$DATTIM(FBBEGDT)_" through "_$$DATTIM($P(FBENDDT,"."))
  1.  ;
  1.  ;
  1.  D ULINE("-") Q:$G(FBQ)
  1.  ; If just printing Summary, no need to print other headers
  1.  I FBSUMDET Q
  1.  D HEADLN1
  1.  D HEADLN2
  1.  D HEADLN3
  1.  D ULINE("-")
  1.  ;
  1.  Q
  1.  ;
  1. EXHDR ; Write the Excel Report Header
  1.  W !,"ID#"_U
  1.  W "PATIENT"_U
  1.  W "ELIG DATE"_U
  1.  W "ELIGIBLE"_U
  1.  W "DETERMINATION"_U
  1.  W "LOCAL JUSTIFICATION"_U
  1.  W "LOCAL VERIFICATION OF MILEAGE"_U
  1.  Q
  1.  ;
  1. DATTIM(X) ;Convert FM date or date.time to displayable (mm/dd/yy HH:MM) format
  1.  N DATE,FBT,FBM,FBH,FBAP
  1.  S DATE=$S(X:$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3),1:"")
  1.  S FBT=$P(X,".",2) S:$L(FBT)<4 FBT=FBT_$E("0000",1,4-$L(FBT))
  1.  S FBH=$E(FBT,1,2),FBM=$E(FBT,3,4)
  1.  S FBAP="AM" I FBH>12 S FBH=FBH-12,FBAP="PM" S:$L(FBH)<2 FBH="0"_FBH
  1.  I FBT S:'FBH FBH=12 S DATE=DATE_" "_FBH_":"_FBM_FBAP
  1.  Q $G(DATE)
  1.  ;
  1. HEADLN1 ; Write the first header line
  1.  W !,"ID#",?8,"Patient",?35,"Elig Date",?51,"Eligible",?64,"Determination"
  1.  Q
  1.  ;
  1. HEADLN2 ; Write the second header line
  1.  W !,?10,"Local Project ARCH Justification"
  1.  Q
  1.  ;
  1. HEADLN3 ; Write the third header line
  1.  W !,?12,"Local Verification of Mileage"
  1.  Q
  1.  ;
  1. XREPORT Q
  1.  ;
  1.  ;left justified, blank padded
  1.  ;adds spaces on right or truncates to make return string FBLEN characters long
  1.  ;FBST- original string
  1.  ;FBLEN - desired length
  1. LJ(FBST,FBLEN) ;
  1.  N FBL
  1.  S FBL=FBLEN-$L(FBST)
  1.  Q $E(FBST_$J("",$S(FBL<0:0,1:FBL)),1,FBLEN)
  1.  ;
  1.  ;right justified, blank padded
  1.  ;adds spaces on left or truncates to make return string FBLEN characters long
  1.  ;FBST- original string
  1.  ;FBLEN - desired length
  1. RJ(FBST,FBLEN)  ;
  1.  S FBL=FBLEN-$L(FBST)
  1.  I FBL>0 Q $J("",$S(FBL<0:0,1:FBL))_FBST
  1.  Q $E(FBST,1,FBLEN)