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

IBAGMR1.m

Go to the documentation of this file. 
  1. IBAGMR1 ;WOIFO/AAT-GMT SINGLE PATIENT REPORT;12-JUL-02
  1.  ;;2.0;INTEGRATED BILLING;**183**;21-MAR-94
  1.  ;; Per VHA Directive 10-93-142, this routine should not be modified
  1.  Q
  1.  ;
  1.  ; Prints report to the current device
  1.  ;
  1.  ; Input:
  1.  ;   IBDFN - Patient IEN
  1.  ;   IBBDT - Beginning date
  1.  ;   IBEDT - Ending date
  1.  ; Output:
  1.  ;   IBQUIT = 1, if user entered "^" (Devices starting with "C-" only)
  1. REPORT ;
  1.  N IBDT,IBDTE,IBDTH,IBCR,IBDA,IBAT,IBTMP,IBZ,IBCL,IBDTBF,IBDTBT
  1.  S IBQUIT=0
  1.  S IBTMP=$NA(^TMP($J,"IBAGMR")) ; The node of TMP array
  1.  K @IBTMP
  1.  ;
  1.  ; Marking beginning and ending of each clock within the range.
  1.  S IBDT="" F  D  Q:'IBDT  Q:(-IBDT)<IBBDT
  1.  . S IBDT=$O(^IBE(351,"AIVDT",IBDFN,IBDT)) Q:'IBDT
  1.  . S IBCL=0 F  D  Q:'IBCL
  1.  .. S IBCL=$O(^IBE(351,"AIVDT",IBDFN,IBDT,IBCL)) Q:'IBCL
  1.  .. S IBZ=$G(^IBE(351,IBCL,0)) Q:IBZ=""
  1.  .. I $P(IBZ,U,4)=3 Q  ; Status - CANCELLED
  1.  .. I (-IBDT)'<IBBDT,(-IBDT)'>IBEDT S @IBTMP@(-IBDT,"C")=IBCL ; Mark the beginning of the clock
  1.  .. ;S IBDTE=$P(+$P(IBZ,U,10),".") ;Expiration date
  1.  .. ;I IBDTE,IBDTE'<IBBDT,IBDTE'>IBEDT S @IBTMP@(IBDTE,"E")=IBCL ; Mark the ending of the clock
  1.  ;
  1.  ; Get the charges from file #350.
  1.  ; IBDT here - Parent Event Date
  1.  S IBDT=-(IBEDT+.00001) F  S IBDT=$O(^IB("AFDT",IBDFN,IBDT)) Q:'IBDT  D
  1.  . S IBCR=0 F  S IBCR=$O(^IB("AFDT",IBDFN,IBDT,IBCR)) Q:'IBCR  D
  1.  .. S IBDA=0 F  S IBDA=$O(^IB("AF",IBCR,IBDA)) Q:'IBDA  D
  1.  ... S IBZ=$G(^IB(IBDA,0)) I 'IBZ Q
  1.  ... Q:$P(IBZ,U,8)["ADMISSION"
  1.  ... ; Bill 'To' and 'From' dates
  1.  ... S IBDTBF=$P(IBZ,U,14),IBDTBT=$P(IBZ,U,15) S:IBDTBT="" IBDTBT=IBDTBF
  1.  ... I IBDTBT<IBBDT Q
  1.  ... I IBDTBF>IBEDT Q
  1.  ... S IBAT=$P(IBZ,U,3) Q:'IBAT  ; Action type is really required
  1.  ... I $$ACTNM^IBOUTL(IBAT)["LTC " Q  ; Exclude LTC action type
  1.  ... S @IBTMP@(+$P(IBZ,U,14),"I"_IBDA)=IBZ
  1.  ;
  1.  D PRINT
  1.  K @IBTMP ; Kill the temporary global node
  1.  S:$D(ZTQUEUED) ZTREQ="@" ; for Taskman
  1.  Q
  1.  ;
  1. PRINT ; Print report from the temp. global
  1.  N IBLINE,IBPAG,IBTOT,IBTOTS,IBPT,IBH,IBD,IBTY,IBDA,IBZ,IBCHG,IBSAV,IBSEQ,IBGMT,X,X2,X3,Y,%,IBCIS
  1.  D NOW^%DTC S IBDTH=$$FMTE^XLFDT($E(%,1,12))
  1.  S IBLINE="",$P(IBLINE,"=",IOM+1)="",(IBPAG,IBTOT,IBTOTS,IBQUIT,IBCHG)=0
  1.  S IBPT=$$PT^IBEFUNC(IBDFN)
  1.  S IBCIS=0
  1.  S IBH="GMT Single Patient Report for "_$P(IBPT,U)_"  "_$P(IBPT,U,2) D HDR
  1.  I '$D(@IBTMP) W !!,"The patient has no MT/GMT bills within the specified period" D PAUSE(1) Q
  1.  ; - first, print detail lines
  1.  S IBD="" F  S IBD=$O(@IBTMP@(IBD)) Q:'IBD  D  Q:IBQUIT
  1.  . S IBTY="" F  S IBTY=$O(@IBTMP@(IBD,IBTY)) Q:IBTY=""  D  Q:IBQUIT
  1.  ..  D CHKSTOP Q:IBQUIT
  1.  ..  I IBTY="C" W !,$$DAT(IBD),?10,"Begin Means Test Billing Clock" K @IBTMP@(IBD,"E") Q
  1.  ..  I IBTY="E" W !,$$DAT(IBD),?10,"Expire Means Test Billing Clock" Q
  1.  ..  W !,$$DAT(IBD)
  1.  ..  S IBDA=+$E(IBTY,2,99),IBZ=$G(^IB(IBDA,0)),IBSEQ=0
  1.  ..  S IBAT=+$P(IBZ,U,3)
  1.  ..  I $P(IBZ,U,14)'=$P(IBZ,U,15) W ?10,$$DAT($P(IBZ,U,15))
  1.  ..  S IBSEQ=$P($G(^IBE(350.1,+$P(IBZ,U,3),0)),U,5)
  1.  ..  W ?20,$E($$ACTNM^IBOUTL(+$P(IBZ,U,3)),1,25)
  1.  ..  W ?46,$$STAT()
  1.  ..  S IBCHG=+$P(IBZ,U,7)
  1.  ..  S IBGMT=$P(IBZ,U,21)
  1.  ..  I IBSEQ=2 S IBCHG=-IBCHG I 'IBGMT S IBGMT=$P($G(^IB(+$P(IBZ,U,9),0)),U,21)
  1.  ..  ; The Charge provide GMT Savings if it has GMT RELATED field set to "1"
  1.  ..  S IBSAV=$S(IBGMT:IBCHG*4,1:0) ;GMT Savings
  1.  ..  I $P(IBZ,U,11)="",$P($G(^IBE(350.21,+$P(IBZ,U,5),0)),U,5) S (IBCHG,IBSAV)=0
  1.  ..  W ?56,$$FORMAT(IBCHG,10) W:IBSAV ?68,$$FORMAT(IBSAV,10)
  1.  ..  S IBTOT=IBTOT+IBCHG ; Total
  1.  ..  S IBTOTS=IBTOTS+IBSAV ; Savings total
  1.  ..  I IBSEQ=2!($P(IBZ,U,11)=""&($P($G(^IBE(350.21,+$P(IBZ,U,5),0)),U,5))) W !?5,"Charge Removal Reason: ",$S($D(^IBE(350.3,+$P(IBZ,U,10),0)):$P(^(0),U),1:"UNKNOWN")
  1.  Q:IBQUIT
  1.  I IBTOT D TOTALS
  1.  D PAUSE(1)
  1.  Q
  1.  ;Number format
  1. FORMAT(IBNUM,IBDIG,IBFRM) ;
  1.  N X,X1,X2,X3
  1.  S X=IBNUM,X2=$G(IBFRM,"2$"),X3=IBDIG
  1.  D COMMA^%DTC
  1.  Q X
  1.  ;
  1. CHKSTOP I $Y>(IOSL-5) D PAUSE(0) Q:IBQUIT  D HDR
  1.  Q
  1.  ;
  1.  ;
  1. HDR ; Print header.
  1.  N IBI
  1.  I $E(IOST,1,2)["C-"!(IBPAG) W @IOF,*13
  1.  S IBPAG=IBPAG+1 W ?(80-$L(IBH)\2),IBH
  1.  W !,"From ",$$DAT(IBBDT)," through ",$$DAT(IBEDT)
  1.  W ?IOM-36,IBDTH,?IOM-9,"Page: ",IBPAG
  1.  W !,"BILL FROM  BILL TO    BILL TYPE",?46,"BILL #    TOT CHRG   TOT GMT DIFF"
  1.  W ! F IBI=1:1:80 W "-"
  1.  Q
  1.  ;
  1. TOTALS N IBI,X
  1.  W !,?56 F IBI=1:1:22 W "-"
  1.  W !,?54,$$FORMAT(IBTOT,12),?66,$$FORMAT(IBTOTS,12)
  1.  Q
  1.  ;
  1. STAT() ; Display bill number or status
  1.  N IBSTAT S IBSTAT=$G(^IBE(350.21,+$P(IBZ,U,5),0))
  1.  Q $S($P(IBSTAT,U,6):$$HLD(+$P(IBZ,U,5)),$P(IBZ,U,5)=99:"Converted",$P(IBZ,U,11)]"":$P($P(IBZ,U,11),"-",2),$P(IBSTAT,U,5):"Cancelled",1:"Pending")
  1.  ;
  1. HLD(STAT) ; Return an 'on hold' status string
  1.  Q "Hold "_$S(STAT=20:"Rate",STAT=21:"Rev",1:"Ins")
  1.  ;
  1. PAUSE(IBEND) ;
  1.  Q:$E(IOST,1,2)'["C-"
  1.  N IBJ,DIR,DIRUT,DTOUT,DUOUT,DIROUT,Y
  1.  W !! ;F IBJ=$Y:1:(IOSL-4) W !
  1.  S DIR(0)="E"
  1.  I $G(IBEND) S DIR("A")="End of the report. Enter RETURN to continue or '^' to exit"
  1.  D ^DIR K DIR I $G(DUOUT) S IBQUIT=1 W @IOF Q
  1.  I $G(IBEND) W @IOF
  1.  Q
  1.  ;
  1. DAT(IBDT) ; Convert FM date to (mm/dd/yy) format.
  1.  Q $$FMTE^XLFDT(IBDT,"2MZ")
  1.  ;
  1.  ; Action Billing Group
  1. BILGR(IBACT) ; Input pointer to Action Type File #350.1
  1.  ; Output - Billing Group
  1.  N IBNEW
  1.  S IBNEW=$P($G(^IBE(350.1,+IBACT,0)),U,9) ;New action type
  1.  Q +$S($P($G(^IBE(350.1,+IBNEW,0)),U,11):$P(^(0),U,11),1:$P($G(^IBE(350.1,+IBACT,0)),U,11))