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

IBAECP.m

Go to the documentation of this file. 
  1. IBAECP ;WOIFO/AAT - LTC SINGLE PATIENT PROFILE ; 20-FEB-02
  1.  ;;2.0;INTEGRATED BILLING;**171,176,199,729**;21-MAR-94;Build 8
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  S:'$D(DTIME) DTIME=300 D HOME^%ZIS
  1.  ;
  1.  ;
  1.  N IBQUIT,POP
  1.  F  S IBQUIT=0 D  Q:IBQUIT
  1.  . N IBDFN,IBCLK,IBDT1,IBDT2,%DT,X,Y,DIC,IBOFD,IBOEV
  1.  . W !
  1.  . S IBDFN=$$ASKPAT() I IBDFN=-1 S IBQUIT=1 Q
  1.  . ; Enter required clock (if more than one)
  1.  . S IBCLK=$$ASKCLK(IBDFN) I IBCLK<1 Q  S IBQUIT=1
  1.  . ; Ask about beginning and ending date and perform action
  1.  . ; No default valies provided
  1.  . ; W !,"The report is not available at the patch IB*2.0*171" Q
  1.  . D DATE I IBDT1<0 Q  S IBQUIT=1 Q  ;Enter date range (defaults are begin/end of the clock)
  1.  . D ASKOFD I IBOFD<0 Q  S IBQUIT=1 Q  ;Option - print free days
  1.  . D ASKOEV I IBOEV<0 Q  S IBQUIT=1 Q  ;Option - print event history
  1.  . D ASKDEV
  1.  Q
  1.  ;
  1. ASKDEV ; Ask about output device and print the report (or run task)
  1.  N %ZIS
  1.  S %ZIS="QM"
  1.  W ! D ^%ZIS Q:POP  ; Quit and ask for patient again. Otherwise Set IBSTOP=1
  1.  ; If it was queued
  1.  I $D(IO("Q")) D RUNTASK Q
  1.  U IO D REPORT^IBAECP1 ; Generate report directly
  1.  D ^%ZISC ; Close the device
  1.  Q
  1.  ;
  1.  ;
  1. RUNTASK ; Start Taskman job
  1.  N ZTRTN,ZTSK,IBVAR,ZTSAVE,ZTDESC
  1.  S ZTRTN="REPORT^IBAECP1",ZTDESC="LTC SINGLE PATIENT BILLING PROFILE"
  1.  F IBVAR="IBDFN","IBCLK","IBDT1","IBDT2","IBOFD","IBOEV" S ZTSAVE(IBVAR)=""
  1.  D ^%ZTLOAD
  1.  K IO("Q")
  1.  D HOME^%ZIS W !
  1.  Q
  1.  ;
  1.  ; User's interface for LTC Billing Clock
  1.  ; If the user has only one clock - doesn't ask, only shows brief info. 
  1.  ; Parameters: 
  1.  ;  IBDFN - patient IEN
  1.  ;  IBSHOW - if 1, the list of clocks will be printed
  1.  ; Returns: LTC Clock IEN (or -1, if canceled, or 0, if the user doesn't has any clocks)
  1. ASKCLK(IBDFN,IBSHOW) N IBDT,IBDT2,IBX,IBZ,IBCNT,IBCL,DIRUT,Y,DIR,IBI,IBY,IBCLK
  1.  I '$D(^IBA(351.81,"AE",IBDFN)) D  Q 0 ; No data for the patient
  1.  . W !,"The user doesn't have LTC Billing Clock created"
  1.  ; Collect all data in IBCL array IBCL(DATE)=IEN,IBCL=<Number of clocks>
  1.  S IBCL=0
  1.  S IBCLK=0,IBDT=0 F  S IBDT=$O(^IBA(351.81,"AE",IBDFN,IBDT)) Q:'IBDT  D
  1.  . S IBX=0 F  S IBX=$O(^IBA(351.81,"AE",IBDFN,IBDT,IBX)) Q:'IBX  D
  1.  .. S IBCL(IBDT)=IBX
  1.  .. S IBCL=IBCL+1
  1.  ;
  1.  ; If there is only one clock - no need to ask, just show
  1.  I IBCL=1 S IBCLK=IBCL($O(IBCL(""))) D LSTCLK W ! Q IBCLK
  1.  K Y
  1.  F  D  Q:$D(DIRUT)  Q:$D(IBCL(Y))  W " ??"
  1.  . ;Choose one
  1.  . I $D(Y)!($G(IBSHOW)) W ! D LSTCLK W ! ; Bad enter - list options
  1.  . K DIR,DIRUT
  1.  . S DIR(0)="FE"
  1.  . S DIR("A")="Choose LTC BILLING CLOCK (1-"_IBCL_")"
  1.  . S DIR("B")=$$FMTE^XLFDT(+$O(IBCL(""),-1),"1D")
  1.  . S DIR("?")="Enter date of the required LTC BILLING CLOCK. Enter '??' for clocks list."
  1.  . S DIR("??")="^D LSTCLK^IBAECP"
  1.  . D ^DIR Q:$D(DIRUT)
  1.  . ; User may enter just number
  1.  . I Y=+Y,Y>0,Y'>IBCL D  I IBY S Y=IBY Q
  1.  .. S IBY="" F IBI=1:1:Y S IBY=$O(IBCL(IBY)) Q:IBY=""
  1.  . S %DT="" D ^%DT ; Convert external to internal format
  1.  I $D(DIRUT) Q -1
  1.  W " (",$$FMTE^XLFDT(Y),")"
  1.  Q IBCL(Y)
  1.  ;
  1.  ; Ask begin/end dates, with default values
  1.  ; Input:  IBCLK - LTC Clock IEN
  1.  ; Output: IBDT1,IBDT2 - begin/end dates
  1. DATE N %DT,Y,IBDT,IBNOW
  1. DATAGN ;Loop entry point
  1.  S (IBDT1,IBDT2)=-1
  1.  ; Get beginning date
  1.  S IBDT=$P($G(^IBA(351.81,IBCLK,0)),U,3)
  1.  S IBDT1=$$ASKDT("Start with DATE: ",IBDT)
  1.  I IBDT1<1 Q
  1.  ; Get ending date
  1.  S IBDT=$P($G(^IBA(351.81,IBCLK,0)),U,4)
  1.  S IBNOW=$$NOW()
  1.  I 'IBDT S IBDT=IBNOW
  1.  E  I IBDT>IBNOW S IBDT=IBNOW
  1.  S IBDT2=$$ASKDT("Go to DATE: ",IBDT)
  1.  I IBDT2<1 S IBDT1=-1 Q
  1.  I IBDT2<IBDT1 W !,"Ending date must follow start date!",! G DATAGN
  1.  Q
  1.  ;
  1.  ;Returns today's date in FM format
  1. NOW() N %,%H,%I,X
  1.  D NOW^%DTC
  1.  Q X
  1.  ;
  1.  ; Ask - print free days or not?
  1.  ; Input: none
  1.  ; Output: IBOFD (bool) IBOFD=-1 if cancelled
  1. ASKOFD ; Default - YES
  1.  N DIR,Y,DUOUT
  1.  S DIR(0)="Y",DIR("A")="Include DAYS NOT SUBJECT TO LTC COPAY on this report",DIR("B")="YES"
  1.  D ^DIR
  1.  S IBOFD=$S($G(DUOUT)!$G(DUOUT)!(Y="^"):-1,1:Y)
  1.  Q
  1.  ; Ask - print LTC events or not?
  1.  ; Input: none
  1.  ; Output: IBOEV (bool) IBOEV=-1 if cancelled
  1. ASKOEV ; Default - YES
  1.  N DIR,Y,DUOUT
  1.  S DIR(0)="Y",DIR("A")="Include LTC EVENTS on this report",DIR("B")="YES"
  1.  D ^DIR
  1.  S IBOEV=$S($G(DUOUT)!$G(DTOUT)!(Y="^"):-1,1:Y)
  1.  Q
  1.  ; Double question mark action - for the "enter clock" dialog
  1.  ; Input:
  1.  ;   IBCL=<Number of clocks>
  1.  ;   IBCL(<Clock date>)=<Clock IEN> local array - list of clocks
  1.  ;   IBDFN= IEN of the patient
  1. LSTCLK N IBZ,IBDT,IBCNT,IBDT2
  1.  W !,$P(^DPT(IBDFN,0),U)," has the following LTC Copay Clock",$S(IBCL>1:"s",1:""),!
  1.  S IBCNT=0
  1.  S IBDT=0 F  S IBDT=$O(IBCL(IBDT)) Q:'IBDT  D
  1.  . S IBX=IBCL(IBDT)
  1.  . S IBZ=^IBA(351.81,IBX,0),IBCNT=IBCNT+1
  1.  . W !?10,IBCNT,?15,$$FMTE^XLFDT(IBDT)
  1.  . S IBDT2=$P(IBZ,U,4)
  1.  . I IBDT2 W ?28," - ",$$FMTE^XLFDT(IBDT2)
  1.  . W ?48,$$EXTERNAL^DILFD(351.81,.05,"",$P(IBZ,"^",5))
  1.  Q
  1.  ;
  1.  ; Input: prompt, default value (FM format)
  1.  ; Output: date (FM) or -1, if cancelled
  1. ASKDT(IBPRMT,IBDFLT) ;Date input
  1.  N DIR,Y,Y0,X,DIROUT,DIRUT
  1.  I $G(IBPRMT)'="" S DIR("A")=IBPRMT
  1.  I $G(IBDFLT)'="" S DIR("B")=$$FMTE^XLFDT(IBDFLT,"1D")
  1.  S DIR(0)="DA"
  1.  D ^DIR I $D(DIRUT) Q -1
  1.  W " (",$$FMTE^XLFDT(Y),")"
  1.  Q Y
  1.  ;
  1.  ;Enter PATIENT NAME (LTC Patients, having a clock only!)
  1.  ;Customized dialog (added more explanation on '??' input)
  1. ASKPAT() N DIR,DIC,Y,X,IBDFN
  1.  F  D  Q:$D(DIRUT)  Q:Y>0
  1.  . S DIR("A")="Select PATIENT NAME"
  1.  . S DIR(0)="FO"
  1.  . S DIR("?")="Enter '??' to list all LTC Patients"
  1.  . S DIR("?",1)="Enter a name of LTC Patient"
  1.  . S DIR("?",2)="Answer with PATIENT NAME, or SOCIAL SECURITY NUMBER, or last 4 digits"
  1.  . S DIR("?",3)="of SOCIAL SECURITY NUMBER, or first initial of last name with last"
  1.  . S DIR("?",4)="4 digits of SOCIAL SECURITY NUMBER"
  1.  . S DIR("?",5)=""
  1.  . S DIR("??")="^D ASKPATQQ^IBAECP"
  1.  . D ^DIR Q:$D(DIRUT)
  1.  . S X=Y
  1.  . I X?3N1"-"2N1"-"4N.3A S X=$TR(X,"-","") ; Remove dashes from SSN
  1.  . S DIC="^DPT(",DIC(0)="QME"
  1.  . S DIC("S")="I $D(^IBA(351.81,""AE"",Y))"
  1.  . S DIC("W")="D WRTPAT^IBAECP(+Y)"
  1.  . N DPTNOFZY S DPTNOFZY=1  ;Suppress PATIENT file fuzzy lookups
  1.  . D ^DIC Q:Y<1  ; Patient code
  1.  . S Y=+$G(Y)
  1.  I $D(DIRUT) Q -1
  1.  Q +Y
  1.  ;
  1. ASKPATQQ N DIC,X,Y,IBDFN,IBI,DIR,DIRUT,DIROUT,DTOUT,DUOUT,IBCNT
  1.  D ASKPHD
  1.  S IBI=7,IBCNT=0
  1.  S IBDFN=0 F  S IBDFN=$O(^IBA(351.81,"AE",IBDFN)) Q:'IBDFN  D  Q:$D(DIRUT)
  1.  . W ! S IBI=IBI+1
  1.  . I IBI>IOSL S DIR(0)="E" D ^DIR W ! Q:$D(DIRUT)  W ! S IBI=3 ; D ASKPHD S IBI=4
  1.  . D WRTPAT(IBDFN)
  1.  Q
  1.  ;
  1. ASKPHD ;Header
  1.  N IBI
  1.  W !,"Choose an LTC Patient:",!
  1.  Q
  1. WRTPAT(IBDFN) ; Write patient's data
  1.  N IBZ,IBVET,IBSC
  1.  S IBZ=$G(^DPT(IBDFN,0)) Q:IBZ="" ""
  1.  S IBSC=($P($G(^DPT(IBDFN,3)),U)="Y")
  1.  S IBVET=($P($G(^DPT(IBDFN,"VET")),U)="Y")
  1.  W $P(IBZ,U)
  1.  W " ",?30,$$FMTE^XLFDT($P($P(IBZ,U,3),"."),"5MZ")
  1.  W " ",?55,$S(IBVET:$S(IBSC:"S/C",1:"NSC")_" VETERAN",1:"")
  1.  W " ",?68,$$FMTE^XLFDT($P($O(^IBA(351.81,"AE",IBDFN,""),-1),"."),"5MZ")
  1.  Q