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

BARBLOS.m

Go to the documentation of this file. 
  1. BARBLOS ; IHS/SD/LSL - REPORT ALL OUTSTANDING BILLS AS OF DATE REQUESTED - JAN 14,1996 ;08/20/2008
  1.  ;;1.8;IHS ACCOUNTS RECEIVABLE;**7**;OCT 26, 2005
  1.  ;;
  1.  ; IHS/SD/LSL - 12/12/02 - V1.6 Patch 4 - NHA-0601-180049
  1.  ;       Tribal sites still use this report.  Removed 3pb search as
  1.  ;       it's not needed and the code does it wrong.
  1.  ;
  1.  ; IHS/SD/LSL - 09/04/03 - V1.7 Patch 4 - IM11410
  1.  ;       Resolved <UNDEF>TRANCAL+5^BARBLOS
  1.  ; MODIFIED TO CHANGE XTMP($J,"BARBLOS" TMP TO MEET SAC REQUIREMENTS;MRS:BAR*1.8*7 IM29892
  1.  ; *********************************************************************
  1.  ;
  1.  D ASK^BARBLOS0
  1.  S BARDATE=$$DIR^XBDIR("D","Enter the ending date","SEP 30, 1997",,"Enter the ending date of the fiscal year to be reported","^D HELP^XBHELP(""HELP"",""BARBLOS"")")
  1.  Q:'Y
  1.  W "  ("_$$MDT2^BARDUTL(BARDATE)_")"
  1.  ;
  1. HELP ;
  1.  ;;In Jan, 1997, auditors from the Inspector General (OIG) requested
  1.  ;;a one-time report from all RPMS A/R implementations.
  1.  ;;Specifically, the information needed by the IG is the amount of
  1.  ;;monies that were outstanding of the end of a fiscal year (ie.
  1.  ;;September 30, 1996).
  1.  ;;
  1.  ;;The results should be faxed to: 
  1.  ;;Carl Fitzpatrick OAM,HQW at 301-443-9157
  1.  ;; 
  1.  ;;Also fax a copy to your Area Office
  1.  ;;###
  1.  ;
  1.  S XBRC="EN^BARBLOS"
  1.  S XBRP="PRINT^BARBLOS"
  1.  S XBNS="BAR"
  1.  S XBRX="EXIT^BARBLOS"
  1.  W *7,!!,">> This report takes a while and will be automatically queued! <<",!
  1.  D ^XBDBQUE
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. EN ;EP 
  1.  K ^XTMP("BARBLOS",$J)
  1.  D INIT^BARUTL
  1.  S BARX="39^40^43^49^108"
  1.  S (BARBLDA,BARBLDT,BARDACT,BAR3PNF)=0
  1.  F  S BARBLDT=$O(^BARBL(DUZ(2),"AG",BARBLDT)) Q:BARBLDT'>0  Q:$E(BARBLDT,1,7)>BARDATE  D
  1.  . S BARBLDA=0
  1.  . F  S BARBLDA=$O(^BARBL(DUZ(2),"AG",BARBLDT,BARBLDA)) Q:BARBLDA'>0  D
  1.  .. S BARDACT=BARDACT+1 I $E(IOST)="C",IOT["TRM" W "."
  1.  .. D SRCHTPB
  1.  . Q
  1.  S (%DT,X1)=DT
  1.  S X="N"
  1.  S X2=7
  1.  D ^%DT
  1.  S Y=X
  1.  S:$D(^XTMP("BARBLOS",$J)) ^XTMP("BARBLOS",$J,0)=Y_"^"_DT_"^"_"IG REPORTING DATA"
  1.  K X,Y
  1.  D HOME^%ZIS
  1.  ;
  1. ENEXIT ;
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. SRCHTPB ;
  1.  D SRCHTRNS
  1.  ;
  1. SRCHTPBE ;
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. SRCHTRNS ;
  1.  ; Search the ^BARTR global for type of transaction records for this A/R bill
  1.  S (BARDTTM,BARCR,BARDB,BARQUIT,BARACCT,BARCNT,BARXOVR)=0
  1.  F  S BARDTTM=$O(^BARTR(DUZ(2),"AC",BARBLDA,BARDTTM)) Q:BARDTTM'>0  Q:BARQUIT  D
  1.  . Q:$P($G(^BARTR(DUZ(2),BARDTTM,0)),U)=""
  1.  . S BARCNT=BARCNT+1
  1.  . I '$D(^BARTR(DUZ(2),BARDTTM,1)) Q
  1.  . D TRANCAL
  1.  I BARCNT=0 Q
  1.  I '$D(BAR(49,0,0,"DB")) D
  1.  . S BAR(49,0,0,"DB")=$$GET1^DIQ(90050.01,BARBLDA,13,"I")
  1.  . S:BARACCT=0 BARACCT=$$GET1^DIQ(90050.01,BARBLDA,3,"I")
  1.  . S ^XTMP("BARBLOS",$J,"NO49REC",BARBLDA)=""
  1.  D CALIT
  1.  I BARDB-BARCR<.01 S BARQUIT=1
  1.  I '$D(^XTMP("BARBLOS",$J,BARACCT,"COLLECTED")) S ^XTMP("BARBLOS",$J,BARACCT,"COLLECTED")=0
  1.  S ^XTMP("BARBLOS",$J,BARACCT,"COLLECTED")=^XTMP("BARBLOS",$J,BARACCT,"COLLECTED")+BARCR
  1.  I BARGRP>0 D
  1.  . I '$D(^XTMP("BARBLOS",$J,BARACCT,"GROUPER")) S ^XTMP("BARBLOS",$J,BARACCT,"GROUPER")=0
  1.  . S ^XTMP("BARBLOS",$J,BARACCT,"GROUPER")=^XTMP("BARBLOS",$J,BARACCT,"GROUPER")+BARGRP
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. PRINT ;
  1.  ; roll through the ^XTMP("BARBLOS",$J) and report on these records
  1.  S BARDATE=BARDATE
  1.  D PRINT^BARBLOS1
  1.  D TRAN^BARBLOS0
  1.  K ^XTMP("BARBLOS",$J)
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. TRANCAL ;
  1.  ; Determine what type of transaction it is
  1.  K BARTEMP
  1.  I BARX'[$P(^BARTR(DUZ(2),BARDTTM,1),"^") Q
  1.  I BARACCT>0 D
  1.  . I BARACCT'=$P(^BARTR(DUZ(2),BARDTTM,0),"^",6) D
  1.  .. S BARTEMP=$P(^BARTR(DUZ(2),BARDTTM,0),"^",6)
  1.  .. S:'$D(^XTMP("BARBLOS",$J,BARACCT,BARTEMP)) ^XTMP("BARBLOS",$J,BARACCT,BARTEMP)=0
  1.  .. S ^XTMP("BARBLOS",$J,BARACCT,BARTEMP)=^XTMP("BARBLOS",$J,BARACCT,BARTEMP)+1
  1.  .. S BARXOVR=BARXOVR+1
  1.  .. D XOVER
  1.  I $P(^BARTR(DUZ(2),BARDTTM,1),"^")=49 D
  1.  . S BARACCT=$P(^BARTR(DUZ(2),BARDTTM,0),"^",6)
  1.  . I '$D(^XTMP("BARBLOS",$J,BARACCT,"BILLED")) S ^XTMP("BARBLOS",$J,BARACCT,"BILLED")=0
  1.  . S ^XTMP("BARBLOS",$J,BARACCT,"BILLED")=^XTMP("BARBLOS",$J,BARACCT,"BILLED")+$P(^BARTR(DUZ(2),BARDTTM,0),"^",3)
  1.  S BARTTYP=$P(^BARTR(DUZ(2),BARDTTM,1),"^")
  1.  S BARTCAT=$P(^BARTR(DUZ(2),BARDTTM,1),"^",2)
  1.  S BARTREA=$P(^BARTR(DUZ(2),BARDTTM,1),"^",3)
  1.  S:BARTCAT="" BARTCAT=0
  1.  S:BARTREA="" BARTREA=0
  1.  I $P(^BARTR(DUZ(2),BARDTTM,0),"^",3)'="" D
  1.  . S:'$D(BAR(BARTTYP,BARTCAT,BARTREA,"DB")) BAR(BARTTYP,BARTCAT,BARTREA,"DB")=0
  1.  . S BAR(BARTTYP,BARTCAT,BARTREA,"DB")=BAR(BARTTYP,BARTCAT,BARTREA,"DB")+$P(^BARTR(DUZ(2),BARDTTM,0),"^",3)
  1.  I $P(^BARTR(DUZ(2),BARDTTM,0),"^",2)'="" D
  1.  . S:'$D(BAR(BARTTYP,BARTCAT,BARTREA,"CR")) BAR(BARTTYP,BARTCAT,BARTREA,"CR")=0
  1.  . S BAR(BARTTYP,BARTCAT,BARTREA,"CR")=BAR(BARTTYP,BARTCAT,BARTREA,"CR")+$P(^BARTR(DUZ(2),BARDTTM,0),"^",2)
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. CALIT ;Calculate the Debits and Credits
  1.  S (BARDB,BARCR,BARGRP)=0
  1.  S BARTTYP=38
  1.  F  S BARTTYP=$O(BAR(BARTTYP)) Q:BARTTYP=""  D
  1.  . S BARTCAT=""
  1.  . F  S BARTCAT=$O(BAR(BARTTYP,BARTCAT)) Q:BARTCAT=""  D
  1.  .. S BARTREA=""
  1.  .. F  S BARTREA=$O(BAR(BARTTYP,BARTCAT,BARTREA)) Q:BARTREA=""  D
  1.  ... I BARTTYP=49 D
  1.  .... S:$D(BAR(BARTTYP,BARTCAT,BARTREA,"DB")) BARDB=BARDB+BAR(BARTTYP,BARTCAT,BARTREA,"DB")
  1.  .... S:$D(BAR(BARTTYP,BARTCAT,BARTREA,"CR")) BARDB=BARDB-BAR(BARTTYP,BARTCAT,BARTREA,"CR")
  1.  ... I BARTTYP'=49 D
  1.  .... S:$D(BAR(BARTTYP,BARTCAT,BARTREA,"DB")) BARCR=BARCR-BAR(BARTTYP,BARTCAT,BARTREA,"DB")
  1.  .... S:$D(BAR(BARTTYP,BARTCAT,BARTREA,"CR")) BARCR=BARCR+BAR(BARTTYP,BARTCAT,BARTREA,"CR")
  1.  ... I BARTCAT=16 D
  1.  .... S:$D(BAR(BARTTYP,BARTCAT,BARTREA,"DB")) BARGRP=BARGRP+BAR(BARTTYP,BARTCAT,BARTREA,"DB")
  1.  .... S:$D(BAR(BARTTYP,BARTCAT,BARTREA,"CR")) BARGRP=BARGRP-BAR(BARTTYP,BARTCAT,BARTREA,"CR")
  1.  ... K BAR(BARTTYP,BARTCAT,BARTREA)
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. XOVER ;
  1.  ; Accumulate cross over dollars, ie-dollars billed to one insurer and paid by another insurer
  1.  I BARXOVR=1 D
  1.  . S:'$D(^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"BILL")) ^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"BILL")=0
  1.  . S ^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"BILL")=^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"BILL")+BAR(49,0,0,"DB")
  1.  I $P(^BARTR(DUZ(2),BARDTTM,0),"^",3)'="" D
  1.  . S:'$D(^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"DB")) ^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"DB")=0
  1.  . S ^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"DB")=^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"DB")+$P(^BARTR(DUZ(2),BARDTTM,0),"^",3)
  1.  I $P(^BARTR(DUZ(2),BARDTTM,0),"^",2)'="" D
  1.  . S:'$D(^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"CR")) ^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"CR")=0
  1.  . S ^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"CR")=^XTMP("BARBLOS",$J,BARACCT,BARTEMP,"CR")+$P(^BARTR(DUZ(2),BARDTTM,0),"^",2)
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. EXIT ; Exit routine
  1.  Q