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

IBTUBAV.m

Go to the documentation of this file.
  1. IBTUBAV ;ALB/AAS - UNBILLED AMOUNTS - AVERAGE BILL AMOUNT LOGIC ; 29-SEP-94
  1. ;;2.0;INTEGRATED BILLING;**19,123**;21-MAR-94
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. % ; - Entry point for manual option.
  1. I '$D(DT) D DT^DICRW
  1. W !
  1. ;
  1. DATE ; - Select date.
  1. W ! D DT2^IBTUBOU("Average Bill Amounts") G:IBTIMON="^" END
  1. ;
  1. DEV ; - Select device.
  1. W !!,"This will automatically be tasked to run and needs no device."
  1. W !!,"A mail Message will be sent when the process completes."
  1. W !,"Use the option View Unbilled Amounts to see cumulative totals.",!!
  1. S ZTRTN="DQ^IBTUBAV",ZTSAVE("IB*")="",ZTIO=""
  1. S ZTDESC="IB - Generate Avg. Bill Amounts for a Month"
  1. D ^%ZTLOAD K IO("Q"),ZTSK D HOME^%ZIS G END
  1. ;
  1. AUTO ; - Entry point for scheduled option (update monthly number of bills
  1. ; and prior 12 months fields).
  1. ;
  1. S IBCOMP=1 ; This will cause the mail msg to be sent to all the users
  1. ; on the Unbilled Amounts mail group (see SEND^IBTUBUL).
  1. ;
  1. DQ ; - Entry point for user options when queued.
  1. K ^TMP($J,"IBTUBAV"),^TMP($J,"IBTUBAV1")
  1. ;
  1. ; - If no IBTIMON or in the future, sets it with current Month
  1. I '$G(IBTIMON)!($G(IBTIMON)>(DT\100*100)) S IBTIMON=DT\100*100
  1. ;
  1. ; - Sets IBGMON with the 1st month 1 year prior to IBTIMON
  1. S IBGMON=IBTIMON-10000
  1. ;
  1. ; AUG/1993 should be the first month in the Unbilled Amounts File
  1. I IBGMON>2930800,'$D(^IBE(356.19,2930800,0)) D
  1. . S IBGMON=2930800
  1. ;
  1. ; - Calculate/Store the Unbilled Amounts Data for the past 12 months
  1. ; (Prior to IBTIMON, does NOT include IBTIMON)
  1. F Q:IBGMON'<IBTIMON D
  1. . ; - If there is no entry for the month, try to create an entry
  1. . I '$D(^IBE(356.19,IBGMON,0)),'$$ADD(IBGMON) D Q
  1. . . S IBGMON=$$FMADD^XLFDT(IBGMON,32)\100*100
  1. . ;
  1. . D MONTH(IBGMON) ; - Calculate MONTHLY totals and store if necessary
  1. . D YEAR(IBGMON) ; - Calculate YEARLY totals and store if necessary
  1. . ;
  1. . S IBGMON=$$FMADD^XLFDT(IBGMON,32)\100*100
  1. ;
  1. ; - Calculate/Store MONTHLY & YEARLY totals for IBTIMON, if not the
  1. ; current month
  1. I $$ADD(IBTIMON),IBTIMON<(DT\100*100) D MONTH(IBTIMON,1)
  1. D YEAR(IBTIMON,1)
  1. ;
  1. I $D(^TMP($J,"IBTUBAV"))!($D(^TMP($J,"IBTUBAV1"))) D SEND
  1. ;
  1. END K ^TMP($J,"IBTUBAV"),^TMP($J,"IBTUBAV1")
  1. I $D(ZTQUEUED) S ZTREQ="@" Q
  1. K IBTIMON,IBCOMP,D,DIRUT,D0,%DT
  1. Q
  1. ;
  1. MONTH(IBYRMO,IBOVRW) ; - Calculate/update Inpatient Unbilled Amounts
  1. ; Input: IBYRMO - YEAR/MONTH (YYYMM00) being calculated/updated
  1. ; IBOVRW - Overwrite the data currently on file? (1-YES/0-NO)
  1. ;
  1. N BGDT,ENDT,IBAVG,IBAMT,IBDA,IBDFN,IBDT,IBNOD,X
  1. ;
  1. I '$G(IBYRMO) Q
  1. K ^TMP($J,"IBTUBAV2")
  1. ;
  1. ; - If MONTHLY Average has already been calculated & NOT Overwrite->QUIT
  1. I '$G(IBOVRW),$P($G(^IBE(356.19,IBYRMO,1)),"^",13)'="" Q
  1. ;
  1. S BGDT=IBYRMO+1,ENDT=IBYRMO+32
  1. ;
  1. ; - Initialize the IBAVG array (set at line tag INPT)
  1. F X="I","P" S (IBAVG("$AMNT-"_X),IBAVG("BILLS-"_X),IBAVG("EPISD-"_X))=0
  1. ;
  1. ; - Loop through date entered x-ref starting a year prior to the period
  1. S IBDT=BGDT-10000
  1. F S IBDT=$O(^DGCR(399,"APD",IBDT)) Q:'IBDT!(IBDT>ENDT) D
  1. . S IBDA=0 F S IBDA=$O(^DGCR(399,"APD",IBDT,IBDA)) Q:'IBDA D
  1. . . S IBNOD=$G(^DGCR(399,+IBDA,0))
  1. . . I $P(IBNOD,U,11)'="i" Q ; Not reimbursable insurance bill
  1. . . S X=$P(IBNOD,U,13) Q:X<3!(X>6) ; Status not authorized or printed
  1. . . S X=$P($G(^DGCR(399,+IBDA,"S")),U,10)
  1. . . I X=""!(X<BGDT)!(X>ENDT) Q ; Date authorized must be in period
  1. . . I $P(IBNOD,U,5)<3 D INPT
  1. ;
  1. ; - Updates file #356.19 with MONTHLY totals (Inpatient)
  1. S IBAVG("$AMNT-I")=$J(IBAVG("$AMNT-I"),0,2)
  1. S IBAVG("$AMNT-P")=$J(IBAVG("$AMNT-P"),0,2)
  1. D LD^IBTUBOU(1,IBYRMO) S ^TMP($J,"IBTUBAV",IBYRMO)=""
  1. ;
  1. K ^TMP($J,"IBTUBAV2") Q
  1. ;
  1. INPT ; - For inpatient bills (add count of bills/total dollars).
  1. S IBDFN=$P(IBNOD,U,2,3),IBAMT=+$G(^DGCR(399,IBDA,"U1"))
  1. I $P(IBNOD,U,27)=1!($P(IBNOD,U,19)=3) D G INP1
  1. . S IBAVG("BILLS-I")=IBAVG("BILLS-I")+1
  1. . S IBAVG("$AMNT-I")=IBAVG("$AMNT-I")+IBAMT
  1. . S IBDFN=IBDFN_"^I"
  1. ;
  1. I $P(IBNOD,U,27)=2!($P(IBNOD,U,19)=2) D G INP1
  1. . S IBAVG("BILLS-P")=IBAVG("BILLS-P")+1
  1. . S IBAVG("$AMNT-P")=IBAVG("$AMNT-P")+IBAMT
  1. . S IBDFN=IBDFN_"^P"
  1. ;
  1. G INPQ
  1. ;
  1. INP1 ; - Add number of inpatient episodes.
  1. I '$D(^TMP($J,"IBTUBAV2",IBDFN)) D
  1. . S Y=$P(IBDFN,U,3),IBAVG("EPISD-"_Y)=IBAVG("EPISD-"_Y)+1
  1. . S ^TMP($J,"IBTUBAV2",IBDFN)=""
  1. ;
  1. INPQ Q
  1. ;
  1. YEAR(IBYRMO,IBOVRW) ; - Calculate YEARLY totals, and store if necessary
  1. ; - Input: IBYRMO - YEAR/MONTH (YYYMM00) being calculated/updated
  1. ; IBOVRW - Overwrite the data currently on file? (1-YES/0-NO)
  1. ;
  1. N IBAVG,IBTMON,IBGMON,IBTNMON,DA,DIC,DIE,DR,SUBCNT,I,X
  1. I IBYRMO>(DT\100*100) G YEARQ ; Don't compile for future months.
  1. ;
  1. ; - If YEARLY Average has already been calculated -> QUIT
  1. I '$G(IBOVRW),$P($G(^IBE(356.19,IBYRMO,1)),"^",14)'="" Q
  1. ;
  1. ; - Initialize the array IBAVG for Institutional and Professional
  1. F X="I","P" D
  1. . S (IBAVG("$AMNT-"_X),IBAVG("BILLS-"_X),IBAVG("EPISD-"_X))=0
  1. ;
  1. ; Sets IBGMON with the 1st day of month 1 year prior to IBYRMO
  1. S IBGMON=IBYRMO-9999,SUBCNT=0
  1. F I=1:1:12 S IBTMON=IBGMON\100*100 Q:IBTMON'<IBYRMO D
  1. . S X=$G(^IBE(356.19,IBTMON,1))
  1. . S IBAVG("BILLS-I")=IBAVG("BILLS-I")+$P(X,U)
  1. . S IBAVG("$AMNT-I")=IBAVG("$AMNT-I")+$P(X,U,2)
  1. . S IBAVG("EPISD-I")=IBAVG("EPISD-I")+$P(X,U,3)
  1. . S IBAVG("BILLS-P")=IBAVG("BILLS-P")+$P(X,U,4)
  1. . S IBAVG("$AMNT-P")=IBAVG("$AMNT-P")+$P(X,U,5)
  1. . S IBAVG("EPISD-P")=IBAVG("EPISD-P")+$P(X,U,6)
  1. . S IBGMON=$$FMADD^XLFDT(IBGMON,31),SUBCNT=SUBCNT+1
  1. ;
  1. I SUBCNT<6 G YEARQ ; If less than 6 months of data don't store.
  1. S IBAVG("$AMNT-I")=$J(IBAVG("$AMNT-I"),0,2)
  1. S IBAVG("$AMNT-P")=$J(IBAVG("$AMNT-P"),0,2)
  1. D LD^IBTUBOU(2,IBYRMO) ; Add to file #356.19 entry.
  1. S ^TMP($J,"IBTUBAV1",IBYRMO)=""
  1. ;
  1. YEARQ Q
  1. ;
  1. SEND ; - Send a mail message to the Unbilled Amounts mail group informing
  1. ; which months had their data (MONTHLY & YEARLY) updated.
  1. N IBCNT,IBGRP,IBDT,IBT,XCNP,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,I,X
  1. S XMSUB="UNBILLED AMOUNTS JOB FOR "_$$DAT2^IBOUTL(IBTIMON)
  1. S IBT(1)="The background job responsible for calculating and updating MONTHLY and"
  1. S IBT(2)="YEARLY Average Bill Amounts and Bill numbers for inpatient episodes has"
  1. S IBT(3)="successfully completed.",IBT(4)=""
  1. S IBCNT=5,IBDT=0
  1. F S IBDT=$O(^TMP($J,"IBTUBAV",IBDT)) Q:'IBDT D
  1. . S IBT(IBCNT)="Monthly totals calculated for "_$$DAT2^IBOUTL(IBDT)
  1. . S IBCNT=IBCNT+1
  1. S IBT(IBCNT)="",IBCNT=IBCNT+1,IBDT=0
  1. F S IBDT=$O(^TMP($J,"IBTUBAV1",IBDT)) Q:'IBDT D
  1. . S IBT(IBCNT)="Yearly totals calculated for "_$$DAT2^IBOUTL(IBDT)
  1. . S IBCNT=IBCNT+1
  1. S IBT(IBCNT)="" D SEND^IBTUBUL
  1. ;
  1. Q
  1. ;
  1. ADD(IBYRMO) ; - Add entry to file 356.19 (unbilled amounts file).
  1. ; Input: IBYRMO=date/time in month year format no days allowed
  1. ; Output: IBADD=1-entry or entry added, 0-not added or error
  1. N IBADD,DA,DD,DIC,DIE,DO,DR,Y S IBADD=0
  1. I IBYRMO'?7N!($E(IBYRMO,6,7)'="00") G ADDQ
  1. I $D(^IBE(356.19,IBYRMO,0)) S IBADD=1 G ADDQ
  1. S DIC="^IBE(356.19,",DIC(0)="L",DLAYGO=356.19
  1. L +^IBE(356.19,IBYRMO):0
  1. I $T S (DINUM,X)=IBYRMO D FILE^DICN I +Y>0 S IBADD=1
  1. L -^IBE(356.19,IBYRMO)
  1. ;
  1. ADDQ Q IBADD