IBJDF61.m

IBJDF61 ;ALB/RB - MISC. BILLS FOLLOW-UP REPORT (COMPILE) ;15-APR-00

 ;;2.0;INTEGRATED BILLING;**123,159,356,618**;21-MAR-94;Build 61

 ;;Per VHA Directive 6402, this routine should not be modified.

 ;

ST ; - Tasked entry point.

 K IB,IBCAT,^TMP("IBJDF6P",$J),^TMP("IBJDF6D",$J) S IBQ=0

 N IBPDFLG   ;Patient (1) or Debtor (0) flag

 ;

 ; - Set selected categories for report.

 ; IB*2.0*618 - Added Community Care Misc. Categories

 I IBSEL[",1," S IBCAT(21)=1        ; MEDICARE

 I IBSEL[",2," S IBCAT(7)=2         ; NO-FAULT AUTO ACCIDENT

 I IBSEL[",3," D                    ; COMMUNITY CARE NO-FAULT AUTO

 . S IBCAT(52)=3

 . S IBCAT(55)=3

 . S IBCAT(58)=3

 I IBSEL[",4," S IBCAT(10)=4        ; TORT FEASOR

 I IBSEL[",5," D                    ; COMMUNITY CARE TORT FEASOR

 . S IBCAT(53)=5

 . S IBCAT(56)=5

 . S IBCAT(59)=5

 I IBSEL[6 S IBCAT(6)=6             ; WORKMEN'S COMP

 I IBSEL[7 D                        ; COMMUNITY CARE NO-FAULT AUTO

 . S IBCAT(54)=7

 . S IBCAT(57)=7

 . S IBCAT(60)=7

 I IBSEL[8 S IBCAT(16)=8            ; CURRENT EMPLOYEE

 I IBSEL[9 S IBCAT(15)=9            ; EX-EMPLOYEE

 I IBSEL[10 S IBCAT(13)=10          ; FEDERAL AGENCIES-REFUND

 I IBSEL[11 S IBCAT(14)=11          ; FEDERAL AGENCIES-REIMBURSEMENT

 I IBSEL[12 S IBCAT(12)=12          ; MILITARY

 I IBSEL[13 S IBCAT(20)=13          ; INTERAGENCY

 I IBSEL[14 S IBCAT(17)=14          ; VENDOR

 ;

 ; Initialize the Summary Information

 S IBCAT="" F  S IBCAT=$O(IBCAT(IBCAT)) Q:IBCAT=""  D

 . S IBDIV=0

 . I IBSDV,$$CATCHK(IBCAT) D  Q    ;IB*2.0*618

 . . F  S IBDIV=$O(VAUTD(IBDIV)) Q:IBDIV=""  D INIT^IBJDF63

 . D INIT^IBJDF63

 ;

 ; - Print the header line for the Excel spreadsheet

 I $G(IBEXCEL) D PHDL

 ;

 ; - Find data required for the report.

 S IBA=0 F  S IBA=$O(^PRCA(430,"AC",16,IBA)) Q:'IBA  D  Q:IBQ

 . I IBA#100=0 D  Q:IBQ

 . . S IBQ=$$STOP^IBOUTL("Miscellaneous Bills Follow-Up Report")

 . S IBAR=$G(^PRCA(430,IBA,0)) Q:'IBAR

 . S IBCAT=+$P(IBAR,U,2) Q:'$D(IBCAT(IBCAT))  ;     Invalid AR category.

 . S IBCAT1=IBCAT(IBCAT),IBPDFLG=$$CATCHK(IBCAT)

 . I IBPDFLG,'$D(^DGCR(399,IBA,0)) Q  ; No claim.

 . I IBPDFLG,$P($G(^DGCR(399,IBA,0)),U,13)=7 Q  ;      Cancelled claim.

 . ;

 . ; - Get division, if necessary.

 . I (IBCAT1>7),(IBCAT1<15) S IBDIV=0   ;IB*2.0*618

 . E  D

 . . I 'IBSDV S IBDIV=0

 . . E  S IBDIV=$$DIV^IBJDF51(IBA)

 . ;

 . I IBSDV,IBDIV,'VAUTD Q:'$D(VAUTD(IBDIV))  ; Not a selected division.

 . ;

 . ; - Get patient or debtor for report.

 . I IBRPT="D" S IBPTDB=$$PTDB(IBA) Q:IBPTDB=""

 . ;

 . ; - Check the receivable age, if necessary.

 . I IBRPT="D",IBSMN D  I (IBARD)<IBSMN!(IBARD>IBSMX) Q

 . . S IBARD=+$$ACT^IBJDF2(IBA) S:IBARD IBARD=$$FMDIFF^XLFDT(DT,IBARD)

 . ;

 . ; - Check the minimum balance amount, if necessary.

 . S IBBA=0 F X=1:1:5 S IBBA=IBBA+$P($G(^PRCA(430,IBA,7)),U,X)

 . I IBRPT="D",IBSAM,IBBA<IBSAM Q

 . ;

 . ; - Get stats for summary

 . I '$G(IBEXCEL) D EN^IBJDF63 Q:IBRPT="S"

 . ;

 . ; - Get remaining AR/claim info and set indexes for detailed report.

 . S (IBFR,IBLP,IBOI,IBTO,IBCLM)="",IBIN=0

 . S IBBN=$P(IBAR,U),IBOR=$P(IBAR,U,3),IBDP=$P(IBAR,U,10)

 . I IBPDFLG D  Q:'IBI!('IBCLM)     ;IB*2.0*618

 . . S IBI=+$G(^DGCR(399,IBA,"MP")) Q:'IBI  ; Get primary ins carrier.

 . . S IBIN=$P($G(^DIC(36,IBI,0)),U)_"@@"_IBI,DFN=$P($P(IBPTDB,U),"@@",2)

 . . S IBDP=$P(IBAR,U,10),IBCLM=$$CLMACT^IBJD(IBA,IBCAT) Q:IBCLM=""

 . . S IBR=$S(+IBCLM=1:$G(^IB($P(IBCLM,U,2),0)),+IBCLM=2:$G(^DGCR(399,IBA,"U")),1:IBDP)

 . . S IBFR=$P(IBR,U,$S(+IBCLM=1:14,1:1)),IBTO=$P(IBR,U,$S(+IBCLM=1:15,+IBCLM=2:2,1:1))

 . . S IBOI=$$OTH(DFN,$P(IBIN,"@@",2),IBFR) ; Get other insurance carrier.

 . . I $G(IBEXCEL) Q

 . . I '($D(^TMP("IBJDF6P",$J,IBDIV,IBCAT,IBIN,$P(IBPTDB,U)))#10) D

 . . . S ^TMP("IBJDF6P",$J,IBDIV,IBCAT,IBIN,$P(IBPTDB,U))=$P(IBPTDB,U,2)_" "_$P(IBPTDB,U,6)_U_$P(IBPTDB,U,3,4)_U_IBOI

 . . S ^TMP("IBJDF6P",$J,IBDIV,IBCAT,IBIN,$P(IBPTDB,U),IBBN)=IBDP_U_IBFR_U_IBTO_U_IBOR_U_IBBA

 . I 'IBPDFLG D

 . . S IBLP=+$P($$PYMT^IBJD1(IBA),U,2)

 . . I '($D(^TMP("IBJDF6D",$J,IBDIV,IBCAT,0,$P(IBPTDB,U)))#10) D

 . . . S ^TMP("IBJDF6D",$J,IBDIV,IBCAT,0,$P(IBPTDB,U))=$P(IBPTDB,U,2)_" "_$P(IBPTDB,U,6)

 . . S ^TMP("IBJDF6D",$J,IBDIV,IBCAT,0,$P(IBPTDB,U),IBBN)=IBDP_U_$P(IBPTDB,U,5)_U_IBOR_U_IBLP_U_IBBA

 . ;

 . I '$G(IBEXCEL) D:IBSH COM Q

 . ;

 . ; - Set up and write line for Excel document.

 . S IBDIV=$P($G(^DG(40.8,$S('IBDIV:+$$PRIM^VASITE(),1:IBDIV),0)),U)

 . S IBEXCEL1=IBDIV_U_$P($G(^PRCA(430.2,IBCAT,0)),U,2)_U_$S(IBIN=0:"",1:$P(IBIN,"@@"))

 . S IBEXCEL1=IBEXCEL1_U_$P(IBPTDB,U,2)_U_$S($P(IBPTDB,"^",6)="*":"E",1:"")_U_$TR($P(IBPTDB,U,4),"-")

 . S IBEXCEL1=IBEXCEL1_U_$P(IBPTDB,U,3)_U_IBOI_U_IBBN_U_$$DT^IBJD(IBDP,1)

 . S IBEXCEL1=IBEXCEL1_U_$$DT^IBJD(IBFR,1)_U_$$DT^IBJD(IBTO,1)_U_IBOR

 . S IBEXCEL1=IBEXCEL1_U_IBLP_U_IBBA_U

 . I IBSH D COM   ;  This will capture the Last Comment Date

 . S IBD=$$FMDIFF^XLFDT(DT,$S('$P(IBEXCEL1,U,17):IBDP,1:$G(DAT)))

 . S IBEXCEL1=IBEXCEL1_U_IBD W !,IBEXCEL1 K IBD,IBEXCEL1

 ;

 I 'IBQ,'$G(IBEXCEL) D EN^IBJDF62 ; Print the report.

 ;

ENQ K ^TMP("IBJDF6P",$J),^TMP("IBJDF6D",$J)

 I $D(ZTQUEUED) S ZTREQ="@" G ENQ1

 ;

 D ^%ZISC

ENQ1 K IBA,IBA1,IBAR,IBARD,IBCAT,IBCAT1,IBDIV,IBD,IBI,IBIN,IBQ,IBR,IBOI,IBBA

 K IBBN,IBCLM,IBDP,IBEXCEL,IBFR,IBLP,IBOR,IBPTDB,IBTO,IBTYP,COM

 K COM1,DAT,DFN,J,X,X1,X2,Y,Z

 Q

 ;

PTDB(X) ; - Find Patient/Debtor and decide to include the AR.

 ;    Input: X=Pointer to the AR in file #430 plus all IBS* variables

 ;   Output: Y=Sort key (name or last 4) and Patient/Debtor IEN(file #2) 

 ;             ^ Patient/Debtor name (1st 25 chars) ^ Age ^ SSN

 ;             ^ Processed by (File #200) ^ Current VA Employee? (*=Yes)

 N AGE,ALL,ARZ,CAT,DEB,DA,DFN,DIC,DIQ,DR,END,IBZ,INI,KEY,NAME,PRC,SSN

 N VA,VADM,VAERR,Y,IBPTFLG

 ;

 S Y="" I '$G(X) G PDQ

 S DFN=0,ARZ=$G(^PRCA(430,X,0)),CAT=$P(ARZ,"^",2)

 S (NAME,AGE,SSN,PRC)=""

 ;

 ; - Look for Patient (Medicare,Tort Feasor,Work's Comp,No-Fault Auto Acc)

 S IBPTFLG=$$CATCHK(CAT)   ;IB*2.0*618

 I IBPTFLG D  I 'DFN S Y="" G PDQ

 . I '$D(^DGCR(399,X,0)) Q

 . S IBZ=^DGCR(399,X,0),DFN=+$P(IBZ,"^",2)

 . S INI=IBSNF,END=IBSNL,ALL=IBSNA

 . D DEM^VADPT S NAME=VADM(1),SSN=$P(VADM(2),"^",2),AGE=VADM(4)

 . S KEY=$S(IBSN="N":NAME,1:$P(SSN,"-",3))

 . ; - Look for Debtor (All the other Categories)

 I 'IBPTFLG  D  I 'DFN S Y="" G PDQ

 . S DIC="^PRCA(430,",DA=X,DR="9;97",DIQ="DEB" D EN^DIQ1

 . S DFN=+$P(ARZ,"^",9) I 'DFN Q

 . S NAME=$G(DEB(430,DA,9)),PRC=$G(DEB(430,DA,97)),KEY=NAME

 . S DIC="^RCD(340,",DA=DFN,DR="110",DIQ="DEB" D EN^DIQ1

 . S SSN=$G(DEB(340,DA,110))  S:SSN=-1 SSN=""

 . S INI=IBSDF,END=IBSDL,ALL=IBSDA

 ;

 I (INI'="@"&('DFN)) S Y="" G PDQ

 I ALL="ALL"&('DFN)!(ALL="NULL"&(DFN)) S Y="" G PDQ

 I INI="@",END="zzzzz" G PDC

 I INI]KEY!(KEY]END) S Y="" G PDQ

 ;

 S KEY=KEY_"@@"_DFN

PDC S Y=KEY_U_$E(NAME,1,25)_U_AGE_U_SSN_U_PRC_U_$$VAEMP(+$TR(SSN,"-"))

PDQ Q Y

 ;

PHDL ; - Print the header line for the Excel spreadsheet

 N X

 S X="Division^Cat.^Prim.Ins.Carrier^Patient/Debtor^VA Empl.?^SSN^Age^"

 S X=X_"Other Ins.Carrier^Bill #^Dt Bill prep.^Bill From Dt^Bill To Dt^"

 S X=X_"Orig.Amt^Lst Pymt Amt^Curr.Bal.^Lst Comm.Dt^Days Lst Comm."

 W !,X

 Q

 ;

VAEMP(SSN) ; - Check if the Patient/Debtor is a current VA Employee

 ; Input:   SSN - Patient/Debtor Social Security Number

 ;Output: VAEMP - "*":Current VA Employee / "":Not a Current VA Employee

 ;

 N IEN I 'SSN Q ""

 S IEN=+$O(^PRSPC("SSN",SSN,0)) Q:'IEN ""

 I $P($G(^PRSPC(IEN,1)),U,33)'="Y" Q "*"

 Q ""

 ;

OTH(DFN,INS,DS) ; - Find a patient's other valid insurance carrier (if any).

 ;   Input: DFN=Pointer to the patient in file #2

 ;          INS=Pointer to the patient's primary carrier in file #36

 ;           DS=Date of service for validity check

 ;  Output: Valid insurance carrier (first 22 chars.) or null

 N Y S Y="" G:'$G(DFN)!('$G(DS)) OTHQ

 S Z=0 F  S Z=$O(^DPT(DFN,.312,Z)) Q:'Z  S X=$G(^(Z,0)) D:X  Q:Y]""

 .I $G(INS),+X=INS Q

 .S X1=$G(^DIC(36,+X,0)) Q:X1=""

 .I $P(X1,U,2)'="N",$$CHK^IBCNS1(X,DS) S Y=$E($P(X1,U),1,22)

 ;

OTHQ Q Y

 ;

COM ; - Get bill comments.

 N IBGLB,DAT,IBA1,IBC,COM,COM1,X1,X2

 ;

 S DAT=0,IBA1=$S(IBSH1="M":999999999,1:0)

 F  S IBA1=$S(IBSH1="M":$O(^PRCA(433,"C",IBA,IBA1),-1),1:$O(^PRCA(433,"C",IBA,IBA1))) Q:'IBA1  D  I IBSH1="M",DAT Q

 . S IBC=$G(^PRCA(433,IBA1,1)) Q:'IBC

 . I $G(IBSH2),$$FMDIFF^XLFDT(DT,+IBC)<IBSH2 Q  ; Comment age not minimum.

 . I $P(IBC,U,2)'=35,$P(IBC,U,2)'=45 Q  ;   Not decrease/comment transact.

 . S DAT=$S(IBC:+IBC\1,1:+$P(IBC,U,9)\1)

 . I $G(IBEXCEL),IBSH1="M" S IBEXCEL1=IBEXCEL1_$$DT^IBJD(DAT,1) Q

 . ;

 . ; - Append brief and transaction comments.

 . K COM,COM1 S COM(0)=DAT,X1=0

 . S COM1(1)=$P($G(^PRCA(433,IBA1,5)),U,2)

 . S COM1(2)=$E($P($G(^PRCA(433,IBA1,8)),U,6),1,70)

 . S COM(1)=COM1(1)_$S(COM1(1)]""&(COM1(2)]""):"|",1:"")_COM1(2)

 . I COM(1)]"" S COM(1)="**"_COM(1)_"**",X1=1

 . ;

 . ; - Get main comments.

 . S X2=0 F  S X2=$O(^PRCA(433,IBA1,7,X2)) Q:'X2  S COM($S(X1:X2+1,1:X2))=^(X2,0)

 . ;

 . S X1="" F  S X1=$O(COM(X1)) Q:X1=""  D

 . . S IBGLB=$S(IBCAT1<8:"IBJDF6P",1:"IBJDF6D")    ;IB*2.0*618

 . . S ^TMP(IBGLB,$J,IBDIV,IBCAT,IBIN,$P(IBPTDB,U),IBBN,IBA1,X1)=COM(X1)

 ;

 Q

CATCHK(IBCAT) ; Check to see if the AR Category should be a patient or Debtor Category

 ; Output: 1 - Patient, 0 - Debtor (default)

 Q:IBCAT=6 1    ;Worker's Comp

 Q:IBCAT=7 1    ;No Fault

 Q:IBCAT=10 1   ;Tort

 Q:IBCAT=21 1   ;Medicare

 I (IBCAT>51),(IBCAT<61) Q 1  ; a WC, TORT or NF category for Community Care

 Q 0

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBJDF61   9576     printed  Feb 18, 2025@23:49:21                                                                                                                                                                                                     Page 2

IBJDF61   ;ALB/RB - MISC. BILLS FOLLOW-UP REPORT (COMPILE) ;15-APR-00

 +1       ;;2.0;INTEGRATED BILLING;**123,159,356,618**;21-MAR-94;Build 61

 +2       ;;Per VHA Directive 6402, this routine should not be modified.

 +3       ;

ST        ; - Tasked entry point.

 +1        KILL IB,IBCAT,^TMP("IBJDF6P",$JOB),^TMP("IBJDF6D",$JOB)

           SET IBQ=0

 +2       ;Patient (1) or Debtor (0) flag

           NEW IBPDFLG

 +3       ;

 +4       ; - Set selected categories for report.

 +5       ; IB*2.0*618 - Added Community Care Misc. Categories

 +6       ; MEDICARE

           IF IBSEL[",1,"

               SET IBCAT(21)=1

 +7       ; NO-FAULT AUTO ACCIDENT

           IF IBSEL[",2,"

               SET IBCAT(7)=2

 +8       ; COMMUNITY CARE NO-FAULT AUTO

           IF IBSEL[",3,"

               Begin DoDot:1

 +9                SET IBCAT(52)=3

 +10               SET IBCAT(55)=3

 +11               SET IBCAT(58)=3

               End DoDot:1

 +12      ; TORT FEASOR

           IF IBSEL[",4,"

               SET IBCAT(10)=4

 +13      ; COMMUNITY CARE TORT FEASOR

           IF IBSEL[",5,"

               Begin DoDot:1

 +14               SET IBCAT(53)=5

 +15               SET IBCAT(56)=5

 +16               SET IBCAT(59)=5

               End DoDot:1

 +17      ; WORKMEN'S COMP

           IF IBSEL[6

               SET IBCAT(6)=6

 +18      ; COMMUNITY CARE NO-FAULT AUTO

           IF IBSEL[7

               Begin DoDot:1

 +19               SET IBCAT(54)=7

 +20               SET IBCAT(57)=7

 +21               SET IBCAT(60)=7

               End DoDot:1

 +22      ; CURRENT EMPLOYEE

           IF IBSEL[8

               SET IBCAT(16)=8

 +23      ; EX-EMPLOYEE

           IF IBSEL[9

               SET IBCAT(15)=9

 +24      ; FEDERAL AGENCIES-REFUND

           IF IBSEL[10

               SET IBCAT(13)=10

 +25      ; FEDERAL AGENCIES-REIMBURSEMENT

           IF IBSEL[11

               SET IBCAT(14)=11

 +26      ; MILITARY

           IF IBSEL[12

               SET IBCAT(12)=12

 +27      ; INTERAGENCY

           IF IBSEL[13

               SET IBCAT(20)=13

 +28      ; VENDOR

           IF IBSEL[14

               SET IBCAT(17)=14

 +29      ;

 +30      ; Initialize the Summary Information

 +31       SET IBCAT=""

           FOR 

               SET IBCAT=$ORDER(IBCAT(IBCAT))

               if IBCAT=""

                   QUIT 

               Begin DoDot:1

 +32               SET IBDIV=0

 +33      ;IB*2.0*618

                   IF IBSDV

                       IF $$CATCHK(IBCAT)

                           Begin DoDot:2

 +34                           FOR 

                                   SET IBDIV=$ORDER(VAUTD(IBDIV))

                                   if IBDIV=""

                                       QUIT 

                                   DO INIT^IBJDF63

                           End DoDot:2

                           QUIT 

 +35               DO INIT^IBJDF63

               End DoDot:1

 +36      ;

 +37      ; - Print the header line for the Excel spreadsheet

 +38       IF $GET(IBEXCEL)

               DO PHDL

 +39      ;

 +40      ; - Find data required for the report.

 +41       SET IBA=0

           FOR 

               SET IBA=$ORDER(^PRCA(430,"AC",16,IBA))

               if 'IBA

                   QUIT 

               Begin DoDot:1

 +42               IF IBA#100=0

                       Begin DoDot:2

 +43                       SET IBQ=$$STOP^IBOUTL("Miscellaneous Bills Follow-Up Report")

                       End DoDot:2

                       if IBQ

                           QUIT 

 +44               SET IBAR=$GET(^PRCA(430,IBA,0))

                   if 'IBAR

                       QUIT 

 +45      ;     Invalid AR category.

                   SET IBCAT=+$PIECE(IBAR,U,2)

                   if '$DATA(IBCAT(IBCAT))

                       QUIT 

 +46               SET IBCAT1=IBCAT(IBCAT)

                   SET IBPDFLG=$$CATCHK(IBCAT)

 +47      ; No claim.

                   IF IBPDFLG

                       IF '$DATA(^DGCR(399,IBA,0))

                           QUIT 

 +48      ;      Cancelled claim.

                   IF IBPDFLG

                       IF $PIECE($GET(^DGCR(399,IBA,0)),U,13)=7

                           QUIT 

 +49      ;

 +50      ; - Get division, if necessary.

 +51      ;IB*2.0*618

                   IF (IBCAT1>7)

                       IF (IBCAT1<15)

                           SET IBDIV=0

 +52              IF '$TEST

                       Begin DoDot:2

 +53                       IF 'IBSDV

                               SET IBDIV=0

 +54                      IF '$TEST

                               SET IBDIV=$$DIV^IBJDF51(IBA)

                       End DoDot:2

 +55      ;

 +56      ; Not a selected division.

                   IF IBSDV

                       IF IBDIV

                           IF 'VAUTD

                               if '$DATA(VAUTD(IBDIV))

                                   QUIT 

 +57      ;

 +58      ; - Get patient or debtor for report.

 +59               IF IBRPT="D"

                       SET IBPTDB=$$PTDB(IBA)

                       if IBPTDB=""

                           QUIT 

 +60      ;

 +61      ; - Check the receivable age, if necessary.

 +62               IF IBRPT="D"

                       IF IBSMN

                           Begin DoDot:2

 +63                           SET IBARD=+$$ACT^IBJDF2(IBA)

                               if IBARD

                                   SET IBARD=$$FMDIFF^XLFDT(DT,IBARD)

                           End DoDot:2

                           IF (IBARD)<IBSMN!(IBARD>IBSMX)

                               QUIT 

 +64      ;

 +65      ; - Check the minimum balance amount, if necessary.

 +66               SET IBBA=0

                   FOR X=1:1:5

                       SET IBBA=IBBA+$PIECE($GET(^PRCA(430,IBA,7)),U,X)

 +67               IF IBRPT="D"

                       IF IBSAM

                           IF IBBA<IBSAM

                               QUIT 

 +68      ;

 +69      ; - Get stats for summary

 +70               IF '$GET(IBEXCEL)

                       DO EN^IBJDF63

                       if IBRPT="S"

                           QUIT 

 +71      ;

 +72      ; - Get remaining AR/claim info and set indexes for detailed report.

 +73               SET (IBFR,IBLP,IBOI,IBTO,IBCLM)=""

                   SET IBIN=0

 +74               SET IBBN=$PIECE(IBAR,U)

                   SET IBOR=$PIECE(IBAR,U,3)

                   SET IBDP=$PIECE(IBAR,U,10)

 +75      ;IB*2.0*618

                   IF IBPDFLG

                       Begin DoDot:2

 +76      ; Get primary ins carrier.

                           SET IBI=+$GET(^DGCR(399,IBA,"MP"))

                           if 'IBI

                               QUIT 

 +77                       SET IBIN=$PIECE($GET(^DIC(36,IBI,0)),U)_"@@"_IBI

                           SET DFN=$PIECE($PIECE(IBPTDB,U),"@@",2)

 +78                       SET IBDP=$PIECE(IBAR,U,10)

                           SET IBCLM=$$CLMACT^IBJD(IBA,IBCAT)

                           if IBCLM=""

                               QUIT 

 +79                       SET IBR=$SELECT(+IBCLM=1:$GET(^IB($PIECE(IBCLM,U,2),0)),+IBCLM=2:$GET(^DGCR(399,IBA,"U")),1:IBDP)

 +80                       SET IBFR=$PIECE(IBR,U,$SELECT(+IBCLM=1:14,1:1))

                           SET IBTO=$PIECE(IBR,U,$SELECT(+IBCLM=1:15,+IBCLM=2:2,1:1))

 +81      ; Get other insurance carrier.

                           SET IBOI=$$OTH(DFN,$PIECE(IBIN,"@@",2),IBFR)

 +82                       IF $GET(IBEXCEL)

                               QUIT 

 +83                       IF '($DATA(^TMP("IBJDF6P",$JOB,IBDIV,IBCAT,IBIN,$PIECE(IBPTDB,U)))#10)

                               Begin DoDot:3

 +84                               SET ^TMP("IBJDF6P",$JOB,IBDIV,IBCAT,IBIN,$PIECE(IBPTDB,U))=$PIECE(IBPTDB,U,2)_" "_$PIECE(IBPTDB,U,6)_U_$PIECE(IBPTDB,U,3,4)_U_IBOI

                               End DoDot:3

 +85                       SET ^TMP("IBJDF6P",$JOB,IBDIV,IBCAT,IBIN,$PIECE(IBPTDB,U),IBBN)=IBDP_U_IBFR_U_IBTO_U_IBOR_U_IBBA

                       End DoDot:2

                       if 'IBI!('IBCLM)

                           QUIT 

 +86               IF 'IBPDFLG

                       Begin DoDot:2

 +87                       SET IBLP=+$PIECE($$PYMT^IBJD1(IBA),U,2)

 +88                       IF '($DATA(^TMP("IBJDF6D",$JOB,IBDIV,IBCAT,0,$PIECE(IBPTDB,U)))#10)

                               Begin DoDot:3

 +89                               SET ^TMP("IBJDF6D",$JOB,IBDIV,IBCAT,0,$PIECE(IBPTDB,U))=$PIECE(IBPTDB,U,2)_" "_$PIECE(IBPTDB,U,6)

                               End DoDot:3

 +90                       SET ^TMP("IBJDF6D",$JOB,IBDIV,IBCAT,0,$PIECE(IBPTDB,U),IBBN)=IBDP_U_$PIECE(IBPTDB,U,5)_U_IBOR_U_IBLP_U_IBBA

                       End DoDot:2

 +91      ;

 +92               IF '$GET(IBEXCEL)

                       if IBSH

                           DO COM

                       QUIT 

 +93      ;

 +94      ; - Set up and write line for Excel document.

 +95               SET IBDIV=$PIECE($GET(^DG(40.8,$SELECT('IBDIV:+$$PRIM^VASITE(),1:IBDIV),0)),U)

 +96               SET IBEXCEL1=IBDIV_U_$PIECE($GET(^PRCA(430.2,IBCAT,0)),U,2)_U_$SELECT(IBIN=0:"",1:$PIECE(IBIN,"@@"))

 +97               SET IBEXCEL1=IBEXCEL1_U_$PIECE(IBPTDB,U,2)_U_$SELECT($PIECE(IBPTDB,"^",6)="*":"E",1:"")_U_$TRANSLATE($PIECE(IBPTDB,U,4),"-")

 +98               SET IBEXCEL1=IBEXCEL1_U_$PIECE(IBPTDB,U,3)_U_IBOI_U_IBBN_U_$$DT^IBJD(IBDP,1)

 +99               SET IBEXCEL1=IBEXCEL1_U_$$DT^IBJD(IBFR,1)_U_$$DT^IBJD(IBTO,1)_U_IBOR

 +100              SET IBEXCEL1=IBEXCEL1_U_IBLP_U_IBBA_U

 +101     ;  This will capture the Last Comment Date

                   IF IBSH

                       DO COM

 +102              SET IBD=$$FMDIFF^XLFDT(DT,$SELECT('$PIECE(IBEXCEL1,U,17):IBDP,1:$GET(DAT)))

 +103              SET IBEXCEL1=IBEXCEL1_U_IBD

                   WRITE !,IBEXCEL1

                   KILL IBD,IBEXCEL1

               End DoDot:1

               if IBQ

                   QUIT 

 +104     ;

 +105     ; Print the report.

           IF 'IBQ

               IF '$GET(IBEXCEL)

                   DO EN^IBJDF62

 +106     ;

ENQ        KILL ^TMP("IBJDF6P",$JOB),^TMP("IBJDF6D",$JOB)

 +1        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

               GOTO ENQ1

 +2       ;

 +3        DO ^%ZISC

ENQ1       KILL IBA,IBA1,IBAR,IBARD,IBCAT,IBCAT1,IBDIV,IBD,IBI,IBIN,IBQ,IBR,IBOI,IBBA

 +1        KILL IBBN,IBCLM,IBDP,IBEXCEL,IBFR,IBLP,IBOR,IBPTDB,IBTO,IBTYP,COM

 +2        KILL COM1,DAT,DFN,J,X,X1,X2,Y,Z

 +3        QUIT 

 +4       ;

PTDB(X)   ; - Find Patient/Debtor and decide to include the AR.

 +1       ;    Input: X=Pointer to the AR in file #430 plus all IBS* variables

 +2       ;   Output: Y=Sort key (name or last 4) and Patient/Debtor IEN(file #2) 

 +3       ;             ^ Patient/Debtor name (1st 25 chars) ^ Age ^ SSN

 +4       ;             ^ Processed by (File #200) ^ Current VA Employee? (*=Yes)

 +5        NEW AGE,ALL,ARZ,CAT,DEB,DA,DFN,DIC,DIQ,DR,END,IBZ,INI,KEY,NAME,PRC,SSN

 +6        NEW VA,VADM,VAERR,Y,IBPTFLG

 +7       ;

 +8        SET Y=""

           IF '$GET(X)

               GOTO PDQ

 +9        SET DFN=0

           SET ARZ=$GET(^PRCA(430,X,0))

           SET CAT=$PIECE(ARZ,"^",2)

 +10       SET (NAME,AGE,SSN,PRC)=""

 +11      ;

 +12      ; - Look for Patient (Medicare,Tort Feasor,Work's Comp,No-Fault Auto Acc)

 +13      ;IB*2.0*618

           SET IBPTFLG=$$CATCHK(CAT)

 +14       IF IBPTFLG

               Begin DoDot:1

 +15               IF '$DATA(^DGCR(399,X,0))

                       QUIT 

 +16               SET IBZ=^DGCR(399,X,0)

                   SET DFN=+$PIECE(IBZ,"^",2)

 +17               SET INI=IBSNF

                   SET END=IBSNL

                   SET ALL=IBSNA

 +18               DO DEM^VADPT

                   SET NAME=VADM(1)

                   SET SSN=$PIECE(VADM(2),"^",2)

                   SET AGE=VADM(4)

 +19               SET KEY=$SELECT(IBSN="N":NAME,1:$PIECE(SSN,"-",3))

 +20      ; - Look for Debtor (All the other Categories)

               End DoDot:1

               IF 'DFN

                   SET Y=""

                   GOTO PDQ

 +21       IF 'IBPTFLG

               Begin DoDot:1

 +22               SET DIC="^PRCA(430,"

                   SET DA=X

                   SET DR="9;97"

                   SET DIQ="DEB"

                   DO EN^DIQ1

 +23               SET DFN=+$PIECE(ARZ,"^",9)

                   IF 'DFN

                       QUIT 

 +24               SET NAME=$GET(DEB(430,DA,9))

                   SET PRC=$GET(DEB(430,DA,97))

                   SET KEY=NAME

 +25               SET DIC="^RCD(340,"

                   SET DA=DFN

                   SET DR="110"

                   SET DIQ="DEB"

                   DO EN^DIQ1

 +26               SET SSN=$GET(DEB(340,DA,110))

                   if SSN=-1

                       SET SSN=""

 +27               SET INI=IBSDF

                   SET END=IBSDL

                   SET ALL=IBSDA

               End DoDot:1

               IF 'DFN

                   SET Y=""

                   GOTO PDQ

 +28      ;

 +29       IF (INI'="@"&('DFN))

               SET Y=""

               GOTO PDQ

 +30       IF ALL="ALL"&('DFN)!(ALL="NULL"&(DFN))

               SET Y=""

               GOTO PDQ

 +31       IF INI="@"

               IF END="zzzzz"

                   GOTO PDC

 +32       IF INI]KEY!(KEY]END)

               SET Y=""

               GOTO PDQ

 +33      ;

 +34       SET KEY=KEY_"@@"_DFN

PDC        SET Y=KEY_U_$EXTRACT(NAME,1,25)_U_AGE_U_SSN_U_PRC_U_$$VAEMP(+$TRANSLATE(SSN,"-"))

PDQ        QUIT Y

 +1       ;

PHDL      ; - Print the header line for the Excel spreadsheet

 +1        NEW X

 +2        SET X="Division^Cat.^Prim.Ins.Carrier^Patient/Debtor^VA Empl.?^SSN^Age^"

 +3        SET X=X_"Other Ins.Carrier^Bill #^Dt Bill prep.^Bill From Dt^Bill To Dt^"

 +4        SET X=X_"Orig.Amt^Lst Pymt Amt^Curr.Bal.^Lst Comm.Dt^Days Lst Comm."

 +5        WRITE !,X

 +6        QUIT 

 +7       ;

VAEMP(SSN) ; - Check if the Patient/Debtor is a current VA Employee

 +1       ; Input:   SSN - Patient/Debtor Social Security Number

 +2       ;Output: VAEMP - "*":Current VA Employee / "":Not a Current VA Employee

 +3       ;

 +4        NEW IEN

           IF 'SSN

               QUIT ""

 +5        SET IEN=+$ORDER(^PRSPC("SSN",SSN,0))

           if 'IEN

               QUIT ""

 +6        IF $PIECE($GET(^PRSPC(IEN,1)),U,33)'="Y"

               QUIT "*"

 +7        QUIT ""

 +8       ;

OTH(DFN,INS,DS) ; - Find a patient's other valid insurance carrier (if any).

 +1       ;   Input: DFN=Pointer to the patient in file #2

 +2       ;          INS=Pointer to the patient's primary carrier in file #36

 +3       ;           DS=Date of service for validity check

 +4       ;  Output: Valid insurance carrier (first 22 chars.) or null

 +5        NEW Y

           SET Y=""

           if '$GET(DFN)!('$GET(DS))

               GOTO OTHQ

 +6        SET Z=0

           FOR 

               SET Z=$ORDER(^DPT(DFN,.312,Z))

               if 'Z

                   QUIT 

               SET X=$GET(^(Z,0))

               if X

                   Begin DoDot:1

 +7                    IF $GET(INS)

                           IF +X=INS