BARDMBS.m

BARDMBS ; IHS/OIT/FCJ - DEBT MANAGEMENT BILL SEARCH ; 26 May 2011  8:41 AM

 ;;1.8;IHS ACCOUNTS RECEIVABLE;**22,23,24**;OCT 26, 2005;Build 69

 ;New routine 5-12-2011 for Debt Letter Management

 ;

 ;Search the A/R Bill file for overdue bills and

 ;and queue letters for overdue bills.

 ;IHS/SD/POT JULY 2013 FIXED BAREND IN DATE "AG" LOOP - BAR*1.8*.23

 ;IHS/SD/POT HEAT152452 2/10/2014 CHK IF PAR/SAT FILE CORECTLY SET UP - BAR*1.8*.24

ST ;

 ;

 D PAR^BARDMU

 G:$G(BARQ) XIT ;P.OTT HEAT152452 2/10/2014 - BAR*1.8*.24

 D VAR

 I $G(BARRPT)'="C" D PARCHK

 G:$G(BARQ) XIT

 I IOST["C-",'$D(IO("S")) W !!,"Searching for overdue bills..."

 ;S BARPSDI-EFF DT,BARDRDT-RUN DATE

 ;start new code bar*1.8*22 SDR

 S X1=BARDRDT

 S X2=-(BARPCD(1)-1)

 D C^%DTC

 S BARDRDT=X

 K X,X1,X2

 ;end new code bar*1.8*22 SDR

 S BARDRDT=$S(BARDRDT<1:BARPSDI,1:BARDRDT)   ;OR EFFECTIVE DATE OR THE LAST TIME RAN, UPDATING INS LIST WILL RESET RUN DATE

 ;start old code bar*1.8*22 SDR

 ;F  S BARDADT=$O(^BARBL(DUZ(2),"AG",BARDADT)) Q:BARDADT=""  D

 ;.Q:BARDADT'<BARDMDT

 ;end old code start new code bar*1.8*22 SDR

 F  S BARDRDT=$O(^BARBL(DUZ(2),"AG",BARDRDT)) Q:BARDRDT=""!(BARDRDT\1>BARDADT)  D  ;- BAR*1.8*.23

 .Q:BARDRDT'<BARDADT

 .;end new code bar*1.8*22 SDR

 .D CHKBIL

 ;I IOST["C-",'$D(IO("S")) W !!,"Number of NEW overdue bills found: ",CNT  ;bar*1.8*22 SDR

 I IOST["C-",'$D(IO("S")) W !!,"Number of NEW overdue bills found: ",BARCNT  ;bar*1.8*22 SDR

 S DIE="^BAR(90052.06,"_BARPIEN_",",DA=DUZ(2)

 S DR="1807///"_DT

 D ^DIE

XIT ;

 ;K BARDADT,BARDMDT,CNT,SUBCNT,DIR,DIE,DR,DA  ;bar*1.8*22 SDR

 K BARDADT,BARDMDT,BARCNT,BARSBCNT,DIR,DIE,DR,DA  ;bar*1.8*22 SDR

 Q

 ;

VAR ;

 ;W $$EN^BARVDF("IOF")  ;bar*1.8*22 SDR

 I IOST["C-",'$D(IO("S")) W $$EN^BARVDF("IOF")  ;bar*1.8*22 SDR

 ;S CNT=0  ;bar*1.8*22 SDR

 S BARCNT=0  ;bar*1.8*22 SDR

 ;S SUBCNT=0  ;bar*1.8*22 SDR

 S BARSBCNT=0  ;bar*1.8*22 SDR

 K DIR

 ;

 ;CALCULATES LETTER 1 PRINT DATE

 S X1=DT

 S X2=-(BARPCD(1)-1)

 D C^%DTC

 S (BARDADT,BARDMDT)=X

 K X,X1,X2

 ;

 ;SET UP ARRAY FOR INS TYPE

 ;start old code bar*1.8*22 SDR

 ;S L=0 

 ;F  S L=$O(^BAR(90052.06,BARPIEN,DUZ(2),19,L)) Q:L'?1N.N  D

 ;.S L1=$P(^BAR(90052.06,BARPIEN,DUZ(2),19,L,0),U)

 ;.S L2=$P($G(^BAR(90053.03,L1,0)),U,2)

 ;.I L2'="" S BARDINS(L2)=""

 ;end old code start new code

 S BARL=0

 F  S BARL=$O(^BAR(90052.06,BARPIEN,DUZ(2),19,BARL)) Q:BARL'?1N.N  D

 .S BARL1=$P(^BAR(90052.06,BARPIEN,DUZ(2),19,BARL,0),U)

 .S BARL2=$$GET1^DIQ(90053.03,BARL1,".01","E")

 .I BARL2'="" S BARDINS(BARL2)=""

 ;end new code

 Q

 ;

PARCHK ;CHECK FOR REQUIRED PARAMETERS

 S BARQ=0

 S BARPAR1=^BAR(90052.06,BARPIEN,DUZ(2),18)

 ;start old code bar*1.8*22 SDR

 ;F L=1:1:4 I (BARPCD(L)="")!(BARPCL(L)="") S BARQ=1 D ERRMSG Q

 ;F L=1,13,14 I $P(BARPAR,U,L)="" S BARQ=1 D ERRMSG Q

 ;F L=1,3,4,5,6,8 I $P(BARPAR1,U,L)="" S BARQ=1 D ERRMSG Q

 ;end old code start new code

 F BARL=1:1:4 I (BARPCD(BARL)="")!(BARPCL(BARL)="") S BARQ=1 D ERRMSG Q

 F BARL=1,13,14 I $P(BARPAR,U,BARL)="" S BARQ=1 D ERRMSG Q

 F BARL=1,3,4,5,6,8 I $P(BARPAR1,U,BARL)="" S BARQ=1 D ERRMSG Q

 ;end new code

 Q

ERRMSG ;

 W !?5,"All of the Required parameters are not set up. You will need to set",!,"these up to continue.",!

 D RTRN^BARDMU

 Q

 ; 

CHKBIL ;

 ;CHECKS FOR BILL AMOUNT > 0

 S BARBIEN=0

 ;F  S BARBIEN=$O(^BARBL(DUZ(2),"AG",BARDADT,BARBIEN)) Q:BARBIEN=""  D  ;bar*1.8*22 SDR

 F  S BARBIEN=$O(^BARBL(DUZ(2),"AG",BARDRDT,BARBIEN)) Q:BARBIEN=""  D  ;bar*1.8*22 SDR

 .;S SUBCNT=SUBCNT+1  ;bar*1.8*22 SDR

 .S BARSBCNT=BARSBCNT+1  ;bar*1.8*22 SDR

 .;I IOST["C-",'$D(IO("S")),SUBCNT#1000 W "."  ;bar*1.8*22 SDR

 .I IOST["C-",'$D(IO("S")),BARSBCNT#1000 W "."  ;bar*1.8*22 SDR

 .;CHECK IF BILL ALREADY IN BARDM

 .Q:$D(^BARDM(DUZ(2),"B",BARBIEN))

 .;CHECKS FOR BILL AMOUNT > 0

 .Q:$P(^BARBL(DUZ(2),BARBIEN,0),U,15)'>0

 .;CHECKS FOR ACCOUNT AND INSURER TYPE

 .; BARDAC=0  ;ACCT POINTER

 .S BARDAC=$P(^BARBL(DUZ(2),BARBIEN,0),U,3)

 .;TEST ACCOUNT FOR TSI TRANSMISSION

 .;I $D(^BAR(90052.06,BARPIEN,DUZ(2),13,"B",BARDAC)) S R=$O(^BAR(90052.06,BARPIEN,DUZ(2),13,"B",BARDAC,0)) Q:$P(^BAR(90052.06,BARPIEN,DUZ(2),13,R,0),U,2)=0  ;bar*1.8*22 SDR

 .I $D(^BAR(90052.06,BARPIEN,DUZ(2),13,"B",BARDAC)) S BARR=$O(^BAR(90052.06,BARPIEN,DUZ(2),13,"B",BARDAC,0)) Q:$P(^BAR(90052.06,BARPIEN,DUZ(2),13,BARR,0),U,2)=0  ;bar*1.8*22 SDR

 .Q:$P(^BARAC(DUZ(2),BARDAC,0),U,7)="N"

 .I $P(^BARAC(DUZ(2),BARDAC,0),U,7)="Y" D ADD Q   ;TEST ACCT=YES

 .;TEST INSURANCE TYPE

 .D INSTYP^BARDMU

 .I BARDITY'="",$D(BARDINS(BARDITY)) D ADD Q

 Q

 ;

ADD ;ADD BILL TO A/R DEBT MAN

 K DD,DO,DINUM

 S (DIE,DIC)="^BARDM("_DUZ(2)_",",DIC(0)="L",X=BARBIEN

 D FILE^DICN

 S:+Y>0 BARDIEN=+Y

 I +Y<0 W !,"ERROR ADDING BILL NUMBER: ",$P(^BARBL(DUZ(2),BARBIEN,0),U) Q

 S DR=".02///A"

 D ^DIE

 ;ADD SUB ENTRY STATUS

 S DA(1)=BARDIEN

 S DIC="^BARDM("_DUZ(2)_","_BARDIEN_",50,",DIC(0)="L",X=DT

 S DIC("P")=$P(^DD(90053.05,50,0),U,2)

 D FILE^DICN

 S:+Y>0 DA=+Y

 I +Y<0 W !,"ERROR ADDING STATUS COMMENTS ENTRY " Q

 S DIE=DIC

 S DR=".02///"_DUZ_";.03///A"

 D ^DIE

 ;ADD LETTER TO SUB-RECORD

 S DA(1)=BARDIEN

 S DIC="^BARDM("_DUZ(2)_","_BARDIEN_",100,",DIC(0)="L",X="CYCLE 1"

 S DIC("P")=$P(^DD(90053.05,100,0),U,2)

 D FILE^DICN

 S:+Y>0 DA=+Y

 I +Y<0 W !,"ERROR ADDING CYCLE ENTRY TO DEBT BILL: ",$P(^BARBL(DUZ(2),BARBIL,0),U) Q

 S DIE=DIC

 S DR=".02///"_BARPCL(1)_";.03///Q"_";.06///"_$P(^BARBL(DUZ(2),BARBIEN,0),U,15)

 D ^DIE

 ;Q WRITE ERROR MESSAGE

 ;S CNT=CNT+1  ;bar*1.8*22 SDR

 S BARCNT=BARCNT+1  ;bar*1.8*22 SDR

 K DIC,DIE,DR,DA

 Q

 ;

BARDMBS   ; IHS/OIT/FCJ - DEBT MANAGEMENT BILL SEARCH ; 26 May 2011  8:41 AM

 +1       ;;1.8;IHS ACCOUNTS RECEIVABLE;**22,23,24**;OCT 26, 2005;Build 69

 +2       ;New routine 5-12-2011 for Debt Letter Management

 +3       ;

 +4       ;Search the A/R Bill file for overdue bills and

 +5       ;and queue letters for overdue bills.

 +6       ;IHS/SD/POT JULY 2013 FIXED BAREND IN DATE "AG" LOOP - BAR*1.8*.23

 +7       ;IHS/SD/POT HEAT152452 2/10/2014 CHK IF PAR/SAT FILE CORECTLY SET UP - BAR*1.8*.24

ST        ;

 +1       ;

 +2        DO PAR^BARDMU

 +3       ;P.OTT HEAT152452 2/10/2014 - BAR*1.8*.24

           IF $GET(BARQ)

               GOTO XIT

 +4        DO VAR

 +5        IF $GET(BARRPT)'="C"

               DO PARCHK

 +6        IF $GET(BARQ)

               GOTO XIT

 +7        IF IOST["C-"

               IF '$DATA(IO("S"))

                   WRITE !!,"Searching for overdue bills..."

 +8       ;S BARPSDI-EFF DT,BARDRDT-RUN DATE

 +9       ;start new code bar*1.8*22 SDR

 +10       SET X1=BARDRDT

 +11       SET X2=-(BARPCD(1)-1)

 +12       DO C^%DTC

 +13       SET BARDRDT=X

 +14       KILL X,X1,X2

 +15      ;end new code bar*1.8*22 SDR

 +16      ;OR EFFECTIVE DATE OR THE LAST TIME RAN, UPDATING INS LIST WILL RESET RUN DATE

           SET BARDRDT=$SELECT(BARDRDT<1:BARPSDI,1:BARDRDT)

 +17      ;start old code bar*1.8*22 SDR

 +18      ;F  S BARDADT=$O(^BARBL(DUZ(2),"AG",BARDADT)) Q:BARDADT=""  D

 +19      ;.Q:BARDADT'<BARDMDT

 +20      ;end old code start new code bar*1.8*22 SDR

 +21      ;- BAR*1.8*.23

           FOR 

               SET BARDRDT=$ORDER(^BARBL(DUZ(2),"AG",BARDRDT))

               IF BARDRDT=""!(BARDRDT\1>BARDADT)

                   QUIT 

               Begin DoDot:1

 +22               IF BARDRDT'<BARDADT

                       QUIT 

 +23      ;end new code bar*1.8*22 SDR

 +24               DO CHKBIL

               End DoDot:1

 +25      ;I IOST["C-",'$D(IO("S")) W !!,"Number of NEW overdue bills found: ",CNT  ;bar*1.8*22 SDR

 +26      ;bar*1.8*22 SDR

           IF IOST["C-"

               IF '$DATA(IO("S"))

                   WRITE !!,"Number of NEW overdue bills found: ",BARCNT

 +27       SET DIE="^BAR(90052.06,"_BARPIEN_","

           SET DA=DUZ(2)

 +28       SET DR="1807///"_DT

 +29       DO ^DIE

XIT       ;

 +1       ;K BARDADT,BARDMDT,CNT,SUBCNT,DIR,DIE,DR,DA  ;bar*1.8*22 SDR

 +2       ;bar*1.8*22 SDR

           KILL BARDADT,BARDMDT,BARCNT,BARSBCNT,DIR,DIE,DR,DA

 +3        QUIT 

 +4       ;

VAR       ;

 +1       ;W $$EN^BARVDF("IOF")  ;bar*1.8*22 SDR

 +2       ;bar*1.8*22 SDR

           IF IOST["C-"

               IF '$DATA(IO("S"))

                   WRITE $$EN^BARVDF("IOF")

 +3       ;S CNT=0  ;bar*1.8*22 SDR

 +4       ;bar*1.8*22 SDR

           SET BARCNT=0

 +5       ;S SUBCNT=0  ;bar*1.8*22 SDR

 +6       ;bar*1.8*22 SDR

           SET BARSBCNT=0

 +7        KILL DIR

 +8       ;

 +9       ;CALCULATES LETTER 1 PRINT DATE

 +10       SET X1=DT

 +11       SET X2=-(BARPCD(1)-1)

 +12       DO C^%DTC

 +13       SET (BARDADT,BARDMDT)=X

 +14       KILL X,X1,X2

 +15      ;

 +16      ;SET UP ARRAY FOR INS TYPE

 +17      ;start old code bar*1.8*22 SDR

 +18      ;S L=0 

 +19      ;F  S L=$O(^BAR(90052.06,BARPIEN,DUZ(2),19,L)) Q:L'?1N.N  D

 +20      ;.S L1=$P(^BAR(90052.06,BARPIEN,DUZ(2),19,L,0),U)

 +21      ;.S L2=$P($G(^BAR(90053.03,L1,0)),U,2)

 +22      ;.I L2'="" S BARDINS(L2)=""

 +23      ;end old code start new code

 +24       SET BARL=0

 +25       FOR 

               SET BARL=$ORDER(^BAR(90052.06,BARPIEN,DUZ(2),19,BARL))

               IF BARL'?1N.N

                   QUIT 

               Begin DoDot:1

 +26               SET BARL1=$PIECE(^BAR(90052.06,BARPIEN,DUZ(2),19,BARL,0),U)

 +27               SET BARL2=$$GET1^DIQ(90053.03,BARL1,".01","E")

 +28               IF BARL2'=""

                       SET BARDINS(BARL2)=""

               End DoDot:1

 +29      ;end new code

 +30       QUIT 

 +31      ;

PARCHK    ;CHECK FOR REQUIRED PARAMETERS

 +1        SET BARQ=0

 +2        SET BARPAR1=^BAR(90052.06,BARPIEN,DUZ(2),18)

 +3       ;start old code bar*1.8*22 SDR

 +4       ;F L=1:1:4 I (BARPCD(L)="")!(BARPCL(L)="") S BARQ=1 D ERRMSG Q

 +5       ;F L=1,13,14 I $P(BARPAR,U,L)="" S BARQ=1 D ERRMSG Q

 +6       ;F L=1,3,4,5,6,8 I $P(BARPAR1,U,L)="" S BARQ=1 D ERRMSG Q

 +7       ;end old code start new code

 +8        FOR BARL=1:1:4

               IF (BARPCD(BARL)="")!(BARPCL(BARL)="")

                   SET BARQ=1

                   DO ERRMSG

                   QUIT 

 +9        FOR BARL=1,13,14

               IF $PIECE(BARPAR,U,BARL)=""

                   SET BARQ=1

                   DO ERRMSG

                   QUIT 

 +10       FOR BARL=1,3,4,5,6,8

               IF $PIECE(BARPAR1,U,BARL)=""

                   SET BARQ=1

                   DO ERRMSG

                   QUIT 

 +11      ;end new code

 +12       QUIT 

ERRMSG    ;

 +1        WRITE !?5,"All of the Required parameters are not set up. You will need to set",!,"these up to continue.",!

 +2        DO RTRN^BARDMU

 +3        QUIT 

 +4       ; 

CHKBIL    ;

 +1       ;CHECKS FOR BILL AMOUNT > 0

 +2        SET BARBIEN=0

 +3       ;F  S BARBIEN=$O(^BARBL(DUZ(2),"AG",BARDADT,BARBIEN)) Q:BARBIEN=""  D  ;bar*1.8*22 SDR

 +4       ;bar*1.8*22 SDR

           FOR 

               SET BARBIEN=$ORDER(^BARBL(DUZ(2),"AG",BARDRDT,BARBIEN))

               IF BARBIEN=""

                   QUIT 

               Begin DoDot:1

 +5       ;S SUBCNT=SUBCNT+1  ;bar*1.8*22 SDR

 +6       ;bar*1.8*22 SDR

                   SET BARSBCNT=BARSBCNT+1

 +7       ;I IOST["C-",'$D(IO("S")),SUBCNT#1000 W "."  ;bar*1.8*22 SDR

 +8       ;bar*1.8*22 SDR

                   IF IOST["C-"

                       IF '$DATA(IO("S"))

                           IF BARSBCNT#1000

                               WRITE "."

 +9       ;CHECK IF BILL ALREADY IN BARDM

 +10               IF $DATA(^BARDM(DUZ(2),"B",BARBIEN))

                       QUIT 

 +11      ;CHECKS FOR BILL AMOUNT > 0

 +12               IF $PIECE(^BARBL(DUZ(2),BARBIEN,0),U,15)'>0

                       QUIT 

 +13      ;CHECKS FOR ACCOUNT AND INSURER TYPE

 +14      ; BARDAC=0  ;ACCT POINTER

 +15               SET BARDAC=$PIECE(^BARBL(DUZ(2),BARBIEN,0),U,3)

 +16      ;TEST ACCOUNT FOR TSI TRANSMISSION

 +17      ;I $D(^BAR(90052.06,BARPIEN,DUZ(2),13,"B",BARDAC)) S R=$O(^BAR(90052.06,BARPIEN,DUZ(2),13,"B",BARDAC,0)) Q:$P(^BAR(90052.06,BARPIEN,DUZ(2),13,R,0),U,2)=0  ;bar*1.8*22 SDR

 +18      ;bar*1.8*22 SDR

                   IF $DATA(^BAR(90052.06,BARPIEN,DUZ(2),13,"B",BARDAC))

                       SET BARR=$ORDER(^BAR(90052.06,BARPIEN,DUZ(2),13,"B",BARDAC,0))

                       IF $PIECE(^BAR(90052.06,BARPIEN,DUZ(2),13,BARR,0),U,2)=0

                           QUIT 

 +19               IF $PIECE(^BARAC(DUZ(2),BARDAC,0),U,7)="N"

                       QUIT 

 +20      ;TEST ACCT=YES

                   IF $PIECE(^BARAC(DUZ(2),BARDAC,0),U,7)="Y"

                       DO ADD

                       QUIT 

 +21      ;TEST INSURANCE TYPE

 +22               DO INSTYP^BARDMU

 +23               IF BARDITY'=""

                       IF $DATA(BARDINS(BARDITY))

                           DO ADD

                           QUIT 

               End DoDot:1

 +24       QUIT 

 +25      ;

ADD       ;ADD BILL TO A/R DEBT MAN

 +1        KILL DD,DO,DINUM

 +2        SET (DIE,DIC)="^BARDM("_DUZ(2)_","

           SET DIC(0)="L"

           SET X=BARBIEN

 +3        DO FILE^DICN

 +4        IF +Y>0

               SET BARDIEN=+Y

 +5        IF +Y<0

               WRITE !,"ERROR ADDING BILL NUMBER: ",$PIECE(^BARBL(DUZ(2),BARBIEN,0),U)

               QUIT 

 +6        SET DR=".02///A"

 +7        DO ^DIE

 +8       ;ADD SUB ENTRY STATUS

 +9        SET DA(1)=BARDIEN

 +10       SET DIC="^BARDM("_DUZ(2)_","_BARDIEN_",50,"

           SET DIC(0)="L"

           SET X=DT

 +11       SET DIC("P")=$PIECE(^DD(90053.05,50,0),U,2)

 +12       DO FILE^DICN

 +13       IF +Y>0

               SET DA=+Y

 +14       IF +Y<0

               WRITE !,"ERROR ADDING STATUS COMMENTS ENTRY "

               QUIT 

 +15       SET DIE=DIC

 +16       SET DR=".02///"_DUZ_";.03///A"

 +17       DO ^DIE

 +18      ;ADD LETTER TO SUB-RECORD

 +19       SET DA(1)=BARDIEN

 +20       SET DIC="^BARDM("_DUZ(2)_","_BARDIEN_",100,"

           SET DIC(0)="L"

           SET X="CYCLE 1"

 +21       SET DIC("P")=$PIECE(^DD(90053.05,100,0),U,2)

 +22       DO FILE^DICN

 +23       IF +Y>0

               SET DA=+Y

 +24       IF +Y<0

               WRITE !,"ERROR ADDING CYCLE ENTRY TO DEBT BILL: ",$PIECE(^BARBL(DUZ(2),BARBIL,0),U)

               QUIT 

 +25       SET DIE=DIC

 +26       SET DR=".02///"_BARPCL(1)_";.03///Q"_";.06///"_$PIECE(^BARBL(DUZ(2),BARBIEN,0),U,15)

 +27       DO ^DIE

 +28      ;Q WRITE ERROR MESSAGE

 +29      ;S CNT=CNT+1  ;bar*1.8*22 SDR

 +30      ;bar*1.8*22 SDR

           SET BARCNT=BARCNT+1

 +31       KILL DIC,DIE,DR,DA

 +32       QUIT 

 +33      ;