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

IBJDF42.m

Go to the documentation of this file. 
  1. IBJDF42 ;ALB/RB - FIRST PARTY FOLLOW-UP REPORT (PRINT);15-APR-00
  1.  ;;2.0;INTEGRATED BILLING;**123,204,568,618,651,705,739**;21-MAR-94;Build 3
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1. EN ; - Print the Follow-up report.
  1.  ;
  1.  S IBCT(1)="INELIGIBLE",IBCT(2)="EMERG/HUMAN.",IBCT(18)="C MEANS TEST"
  1.  S IBCT(22)="RX COPAY/SC",IBCT(23)="RX COPAY/NSC"
  1.  S IBCT(33)="ADHC LTC"
  1.  S IBCT(34)="DOM LTC"
  1.  S IBCT(35)="RESPITE INPT LTC"
  1.  S IBCT(36)="RESPITE OPT LTC"
  1.  S IBCT(37)="GERIATRIC INPT LTC"
  1.  S IBCT(38)="GERIATRIC OPT LTC"
  1.  S IBCT(39)="NURSING HOME LTC"
  1.  ;
  1.  ; PRCA*4.5*338 Adding new categories for community care
  1.  ;
  1.  ; next are the new AR categories
  1.  S IBCT(61)="CHOICE INPT"
  1.  S IBCT(62)="CHOICE RX CO-PAYMENT"
  1.  S IBCT(63)="CC INPT"
  1.  S IBCT(64)="CC RX CO-PAYMENT"
  1.  S IBCT(65)="CCN INPT"
  1.  S IBCT(66)="CCN RX CO-PAYMENT"
  1.  S IBCT(67)="CC MTF INPT"
  1.  S IBCT(68)="CC MTF RX CO-PAYMENT"
  1.  S IBCT(69)="CC NURSING HOME CARE - LTC"
  1.  S IBCT(70)="CC RESPITE CARE"
  1.  S IBCT(71)="CCN NURSING HOME CARE - LTC"
  1.  S IBCT(72)="CCN RESPITE CARE"
  1.  S IBCT(73)="CHOICE NURSING HOME CARE - LTC"
  1.  S IBCT(74)="CHOICE RESPITE CARE"
  1.  S IBCT(81)="CHOICE OPT"
  1.  S IBCT(82)="CC OPT"
  1.  S IBCT(83)="CCN OPT"
  1.  S IBCT(84)="CC MTF OPT"
  1.  S IBCT(85)="CC URGENT CARE"     ;IB*2.0*651 - added
  1.  ;
  1.  S IBQ=0 D NOW^%DTC S IBRUN=$$DAT2^IBOUTL(%) G:IBRPT="S" SUM
  1.  I IBRPT="O" G OSUM
  1.  S IBPRTFLG=0 D DET D PAUSE:'IBPRTFLG I IBQ!'IBPRTFLG G ENQ
  1.  ;
  1.  D PAUSE I IBQ G ENQ
  1.  ;
  1. SUM I 'IBQ D PRT^IBJDF43 ; Print summary.
  1. OSUM I 'IBQ D OSUM^IBJDF43 ; Print Overall Summary
  1. ENQ K IB0,IBAI,IBC,IBCAT,IBCD,IBC1,IBC2,IBCT,IBCNT,IBN,IBP,IBPAG,IBQ,IBRUN,IBS
  1.  K IBST,IBTOT,%,DFN,IBPRTFLG
  1.  Q
  1.  ;
  1. DET ; - Print report for a specific category.
  1.  ;
  1.  D HDR1 G:IBQ DETQ
  1.  S (IBPT,IB,IBCAT,IB0)=""
  1.  F  S IBPT=$O(^TMP("IBJDF4",$J,IBPT)) Q:IBPT=""  D  Q:IBQ
  1.  . I $O(^TMP("IBJDF4",$J,IBPT,0))="" Q
  1.  . S IBP=$G(^TMP("IBJDF4",$J,IBPT))
  1.  . I $Y>(IOSL-14) D PAUSE Q:IBQ  D HDR1 Q:IBQ
  1.  . D WPAT
  1.  . F IB=16,19 D  Q:IBQ
  1.  . . I IBSTA="A",IB'=16 Q
  1.  . . I IBSTA="S",IB=16 Q
  1.  . . I '$D(^TMP("IBJDF4",$J,IBPT,IB)) D  Q
  1.  . . . I $Y>(IOSL-5) D PAUSE Q:IBQ  D HDR1,WPAT,HDR2 Q:IBQ
  1.  . . . W !,"-> NO "_$S(IB=16:"ACTIVE",1:"SUSPENDED")_" BILLS."
  1.  . . I $Y>(IOSL-9) D PAUSE Q:IBQ  D HDR1,WPAT Q:IBQ
  1.  . . D HDR2
  1.  . . K IBFLG S IBTOT="",IBCNT=0
  1.  . . F  S IBCAT=$O(^TMP("IBJDF4",$J,IBPT,IB,IBCAT)) Q:IBCAT=""  D  Q:IBQ
  1.  . . . F  S IB0=$O(^TMP("IBJDF4",$J,IBPT,IB,IBCAT,IB0)) Q:IB0=""  D  Q:IBQ
  1.  . . . . S IBN=$G(^TMP("IBJDF4",$J,IBPT,IB,IBCAT,IB0))
  1.  . . . . I $Y>(IOSL-5) D PAUSE Q:IBQ  D HDR1,WPAT,HDR2 Q:IBQ
  1.  . . . . D WBIL Q:IBQ
  1.  . . . . S IBCNT=IBCNT+1
  1.  . . . I 'IBQ,$O(^TMP("IBJDF4",$J,IBPT,IB,IBCAT))="" D
  1.  . . . . D TOT W !
  1.  . . ; - Display bill comment history, if selected.
  1.  . . S IBPRTFLG=1
  1.  . . D WCOM(IBPT,IB)
  1.  ;
  1.  I 'IBPRTFLG D
  1.  . W !!!!!!,"There are no receivables for the parameters entered."
  1.  ;
  1. DETQ Q
  1.  ;
  1. WPAT ; - Write patient data.
  1.  N I,X
  1.  S DFN=$P(IBPT,"@@",2),IBAI=$G(^TMP("IBJDF4",$J,IBPT,0,"A"))
  1.  W !!,"Patient Name     : ",$P(IBP,U) W:IBAI["V" " *"
  1.  W !,"Means Test Status: ",$P(IBP,U,4) ;IB*2.0*739
  1.  W:$P(IBP,U,5)'="" " ("_$P(IBP,U,5)_")"
  1.  W ?58,"Medicaid: ",$$GET1^DIQ(2,DFN,.381)
  1.  W !,"RX Copay Status  : ",$P(IBP,U,6)
  1.  W:$P(IBP,U,7)'="" " ("_$P(IBP,U,7)_")"
  1.  W:$P(IBP,U,8) ?53,"Date of Death: ",$$DAT1^IBOUTL($P(IBP,U,8))
  1.  W !,"Eligibilities    : " S X=$$ELIG($P(IBP,U,3))
  1.  F I=1:1 Q:X=""  W ?19,$E(X,1,61) S X=$E(X,62,999) I X'="" W !
  1.  S X=$$INFO(IBAI)
  1.  I X'="" D
  1.  . W !,"Additional Info  : "
  1.  . F I=1:1 Q:X=""  W ?19,$E(X,1,61) S X=$E(X,62,999) I X'="" W !
  1.  ;
  1.  Q
  1.  ;
  1. WBIL ; - Write bill data.
  1.  W ! W:'$D(IBFLG(IBCAT)) $E(IBCT(IBCAT),1,11) W ?13,IB0   ;IB*2.0*618 - Limit length to 11 chars
  1.  W:$P(IBN,"^",6) ?25,$J("("_$P(IBN,"^",6)_")",4)
  1.  W ?30,$$DAT1^IBOUTL(+IBN)
  1.  W ?39,$J($FN($P(IBN,U,2),",",2),10),?50,$J($FN($P(IBN,U,3),",",2),10)
  1.  W ?61,$J($FN($P(IBN,U,4),",",2),9),?71,$J($FN($P(IBN,U,5),",",2),9)
  1.  I "SB"[IBSTA,$P(IBN,U,7)]"" W ?82,IBSUS($P(IBN,U,7))
  1.  S $P(IBTOT,"^")=$P(IBTOT,"^")+$P(IBN,U,2)
  1.  S $P(IBTOT,"^",2)=$P(IBTOT,"^",2)+$P(IBN,U,3)
  1.  S $P(IBTOT,"^",3)=$P(IBTOT,"^",3)+$P(IBN,U,4)
  1.  S $P(IBTOT,"^",4)=$P(IBTOT,"^",4)+$P(IBN,U,5)
  1.  S IBFLG(IBCAT)=""
  1.  Q
  1.  ;
  1. WCOM(IBPT,IB) ; - Write bill comments.
  1.  N CMDT,CONT,DIWL,DIWR,IBIDX,IBTR,IBLN,IBX,X
  1.  ;
  1.  S (IBIDX,IBTR,IBLN)="",DIWL=1,DIWR=64 K ^UTILITY($J,"W")
  1.  F  S IBIDX=$O(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX)) Q:IBIDX=""  D  Q:IBQ
  1.  . I $Y>(IOSL-6) D WCPB Q:IBQ
  1.  . D WCD(IBIDX)
  1.  . F  S IBTR=$O(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX,IBTR)) Q:IBTR=""  D  Q:IBQ
  1.  . . S CMDT=$G(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX,IBTR))
  1.  . . I $Y>(IOSL-4) D WCPB Q:IBQ
  1.  . . S CONT=0 D WCD(,1,)
  1.  . . F  S IBLN=$O(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX,IBTR,IBLN)) Q:IBLN=""  D  Q:IBQ
  1.  . . . S IBX=$G(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX,IBTR,IBLN))
  1.  . . . I $E(IBX)=" ",$L(IBX)>1 S $E(IBX)=""
  1.  . . . S X=IBX D ^DIWP
  1.  . . . I 'CONT,$L(IBX)<66 D WCTX
  1.  . . . S CONT=$L(IBX)>65
  1.  . . . I '$O(^TMP("IBJDF4",$J,IBPT,0,"C",IB,IBIDX,IBTR,IBLN)) D
  1.  . . . . D:$D(^UTILITY($J,"W")) WCTX
  1.  K ^UTILITY($J,"W")
  1.  Q
  1.  ;
  1. WCD(I,D,C) ; - Write the comment date.
  1.  ; Input: I - Index #         "(I)"
  1.  ;        D - Print the Date  " - MM/DD/YY"
  1.  ;        C - Print the Cont. "(Continued)"
  1.  ;
  1.  W:$G(I) !,"(",I,")" W:$G(D) ?3," - ",$$DAT1^IBOUTL(CMDT),": "
  1.  W:$G(C) "(Continued)",!
  1.  Q
  1.  ;
  1. WCTX ; - Write the comment text.
  1.  N LIN,WLIN,Z
  1.  S LIN=""
  1.  F  S LIN=$O(^UTILITY($J,"W",1,LIN)) Q:LIN=""  D  Q:IBQ
  1.  . S WLIN=$G(^UTILITY($J,"W",1,LIN,0)) Q:WLIN=""
  1.  . W ?16,WLIN
  1.  . I '$O(^UTILITY($J,"W",1,LIN)) W ! Q
  1.  . I $Y>(IOSL-4) D WCPB,WCD(IBIDX,1,1) Q
  1.  . W !
  1.  K ^UTILITY($J,"W")
  1.  Q
  1.  ;
  1. WCPB ; - Page Break in the middle of the Comments
  1.  D PAUSE Q:IBQ  D HDR1,WPAT W !!
  1.  Q
  1.  ;
  1. HDR1 ; - Write the report header.
  1.  N X,I
  1.  W:'$G(IBPAG) ! I $E(IOST,1,2)="C-"!$G(IBPAG) W @IOF,*13
  1.  S IBPAG=$G(IBPAG)+1 W "First Party Follow-Up Report"
  1.  W ?34,"Run Date: ",IBRUN,?71,"Page: ",$J(IBPAG,3)
  1.  S X="ALL "_$S(IBSTA'="S":"ACTIVE",1:"")_$S(IBSTA="B":" AND ",1:"")
  1.  S X=X_$S(IBSTA'="A":"SUSPENDED",1:"")_" RECEIVABLES"
  1.  I IBSMN'="A" S X=X_" OVER "_IBSMN_" AND UNDER "_IBSMX_" DAYS OLD"
  1.  S X=X_" / BY "_$S(IBSN="N":"NAME",1:"LAST 4 SSN")
  1.  S X=X_" ("_$S($G(IBSNA)="ALL":"ALL",1:"From "_$S(IBSNF="":"FIRST",1:IBSNF)_" to "_$S(IBSNL="zzzzz":"LAST",1:IBSNL))_")"
  1.  S X=X_" / "_$S('IBSAM:"NO ",1:"")_"MINIMUM BALANCE"
  1.  S X=X_$S(IBSAM:": $"_$FN(IBSAM,",",2),1:"")
  1.  S X=X_" / "_$S('IBSH:"NO ",IBSH1="A":"ALL ",1:"ONLY ")_"COMMENTS"
  1.  S X=X_$S($G(IBSH2):" LESS THAN "_IBSH2_" DAYS OLD",1:"")
  1.  S X=X_" / RECEIVABLES REFERRED TO RC "_$S('IBSRC:"NOT ",1:"")_"INCLUDED"
  1.  F I=1:1 W !,$E(X,1,80) S X=$E(X,81,999) I X="" Q
  1.  ;
  1.  S IBQ=$$STOP^IBOUTL("First Party Follow-Up Report")
  1.  Q
  1.  ;
  1. TYPE(SEL) ; Returns a string with the type of receivables (description)
  1.  ; selected or NULL if ALL receivable type have been selected.
  1.  ; SEL - User input for the parameter "Type of Receivable"
  1.  ;
  1.  N TYPE,I,X
  1.  I SEL="1,2,3," Q ""
  1.  S TYPE="",X="EMERGENCY/HUMANITARIAN^INELIGIBLE^C-MEANS TEST & RX COPAY"
  1.  F I=2:1:($L(SEL,",")-1) D
  1.  . S TYPE=TYPE_$S(I=($L(SEL,",")-1)&(TYPE'=""):" AND ",1:", ")
  1.  . S TYPE=TYPE_$P(X,"^",+$P(SEL,",",I))
  1.  S $E(TYPE,1)=""
  1.  ;
  1.  Q TYPE
  1.  ;
  1. HDR2 ; - Write bill sub-header.
  1.  W ! I IBSTA="B" W !,$S(IB=16:"ACTIVE",1:"SUSPENDED")
  1.  W ! I IBSTA="B" W $S(IB=16:"======",1:"=========")
  1.  W:IBSH ?26,"COM" W ?30,"Last",?40,"Current",?51,"Principal"
  1.  W !,"Category",?13,"Bill Number",?26,"REF"
  1.  W ?30,"Payment",?40,"Balance",?51,"Balance",?62,"Interest",?72,"Admin."
  1.  I "BS"[IBSTA W ?82,"Suspended Type"
  1.  W !,$$DASH(96,1)
  1.  Q
  1.  ;
  1. TOT ; - Write balance total for patient.
  1.  N I,J
  1.  I IBCNT>1 W ! F I=40,51,62,72 W ?I,$E("---------",1,$S(I>60:8,1:9))
  1.  W:IBCNT'>1 !
  1.  W !,"Account Balance: $"_$FN($P(IBP,"^",10),",",2)
  1.  I IBCNT'>1 Q
  1.  S J=1 F I=39,50,60,70 W ?I,$J($FN($P(IBTOT,"^",J),",",2),10) S J=J+1
  1.  Q
  1.  ;
  1. DASH(X,Y) ; - Return a dashed line.
  1.  Q $TR($J("",X)," ",$S(Y:"-",1:"="))
  1.  ;
  1. ELIG(X) ; - Return eligibility code name.
  1.  ; X - Eligibility codes separated by semi-collon (;)
  1.  ;
  1.  N ELIG,I
  1.  S ELIG="" F I=1:1:$L(X,";") D
  1.  . I '$P(X,";",I) Q
  1.  . S ELIG=ELIG_", "_$E($P($G(^DIC(8,+$P(X,";",I),0)),U),1,20)
  1.  S $E(ELIG,1,2)=""
  1.  ;
  1.  Q ELIG
  1.  ;
  1. INFO(X) ; - Return the patient Additional Information about the Patient Accout
  1.  ; X - Flags representing the observations
  1.  ;
  1.  N INFO,I
  1.  S INFO="" F I=1:1:$L(X) D
  1.  . I $E(X,I)="V" S INFO=INFO_", '*' - VA EMPLOYEE"
  1.  . I $E(X,I)="R" S INFO=INFO_", REFERRED TO RC"
  1.  . I $E(X,I)="D" S INFO=INFO_", REFERRED TO DMC"
  1.  . I $E(X,I)="T" S INFO=INFO_", REFERRED TO TOP"
  1.  . I $E(X,I)="P" S INFO=INFO_", UNDER REPAYMENT PLAN"
  1.  . I $E(X,I)="F" S INFO=INFO_", UNDER DEFAULTED REPAYMENT PLAN"
  1.  S $E(INFO,1,2)=""
  1.  ;
  1.  Q INFO
  1.  ;
  1. SSN(X) ; - Format the SSN.
  1.  Q $S(X]"":$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),1:"")
  1.  ;
  1. PAUSE ; - Page break.
  1.  I $E(IOST,1,2)'="C-" Q
  1.  N IBX,DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y
  1.  F IBX=$Y:1:(IOSL-3) W !
  1.  S DIR(0)="E" D ^DIR S:$D(DIRUT)!($D(DUOUT)) IBQ=1
  1.  Q