Routine: BARUFUT6

BARUFUT6 ; IHS/SD/TPF - UTILITIES FOR UFMS - PRINT BATCHES WITH SCHEDULE NUMBER POPULATED ;04/10/08

 ;;1.8;IHS ACCOUNTS RECEIVABLE;**4,23**;OCT 26, 2005

 ;NEW ROUTINE BAR*1.8*4 SCR80 4.1.2

 ; IHS/SD/SDR - v1.8 p6 - DD item 4.1.2

 ;   added fields check# and check amt

EN ;EP - PRINT OUT BATCH AND ITEM WITH SCHEDULE NUMBER POPULATED

 N BARCOL,BARITEM,IPAC,DUZ2,TEMPDUZ2,CREDDEB,TRDATE,IPACX

 W !!,"This report will go through A/R payment transactions posted from 10/1/07 forward"

 W !,"and print collection batch information about every batch that was posted to."

W !

 K DIR

 S DIR(0)="FO"

 S DIR("A")="Enter path"

 D ^DIR K DIR

 Q:$D(DTOUT)!$D(DIROUT)!$D(DUOUT)!(Y="")

 S PATH=Y

 S DIR(0)="FO"

 S DIR("A")="Enter filename"

 D ^DIR K DIR

 G:$D(DTOUT)!$D(DIROUT)!$D(DUOUT)!(Y="") EN

 S FILENAME=Y

 K ^XTMP("BARUFUT6",$J)

 S TEMPDUZ2=DUZ(2)

 S DUZ(2)=1

 F  S DUZ(2)=$O(^BARTR(DUZ(2))) Q:'DUZ(2)  D

 . S TRDATE=3070930.999999  ;PULL ONLY TRANSACTIONS FROM 10/1/2007 AND AFTER

 . F  S TRDATE=$O(^BARTR(DUZ(2),TRDATE)) Q:'TRDATE  D

 .. Q:'$$IHS^BARUFUT(DUZ(2))  ;DO ONLY IHS SITES

 .. ;;;Q:'$$IHSERA^BARUFUT(DUZ(2))  ;P.OTT DO ONLY IHS SITES AND TRIBAL WITH FLAG

 .. Q:$$GET1^DIQ(90050.03,TRDATE_",",101,"E")'="PAYMENT"  ;A/R TRANSACTIONS, TRANS TYPE'=PAYMENT

 .. S BARCOL=$$GET1^DIQ(90050.03,TRDATE_",",14,"I")  ;A/R TRANSACTIONS, A/R COLLECTION BATCH PTR

 .. Q:'BARCOL                       ;NO COLLECTION BATCH

 .. S BARITEM=$$GET1^DIQ(90050.03,TRDATE_",",15,"I") ;A/R TRANSACTIONS, A/R COLLECTION ITEM NUMBER

 .. I BARITEM="" D  Q               ;NO ITEM NUMBER

 ... S ^XTMP("BARUFUT6",$J,DUZ(2),"NO ITEM#",BARCOL,"MISSING",TRDATE)=""

 .. S IPAC=$$GET1^DIQ(90051.1101,BARITEM_","_BARCOL_",",20,"E")

 .. S:'$$GOODIPAC^BARUFEX3(IPAC) IPAC="BAD TDN: "_IPAC

 .. S ^XTMP("BARUFUT6",$J,DUZ(2),IPAC,BARCOL,BARITEM)=TRDATE

 I '$D(^XTMP("BARUFUT6",$J)) W !!,"NO DATA FOUND." H 3 G EN

 D PRINT

 I $G(POP) W !!,"COULD NOT OPEN FILE!! TRY AGAIN." H 3 G EN

 S DUZ(2)=TEMPDUZ2

PRINT ;EP - PRINT

 N FACILITY,TRDATE,IPAC,ARCOL,COL,ARCOLNM,ARSTAT

 N CREDDEB,ARITEM,CNT,ARACCT,ITEMSTAT

 K POP

 D OPEN^%ZISH("FILE",PATH,FILENAME,"W")

 Q:$G(POP)

 ;W !,"COLLECTION BATCH",U,"STATUS",U,"FACILITY",U,"A/R ACCOUNT",U,"ITEM",U,"SCHEDULE#",U,"CREDIT-DEBIT"  ;bar*1.8*4 SCR83  ;IHS/SD/SDR bar*1.8*6 DD item 4.1.2

 W !,"COLLECTION BATCH",U,"STATUS",U,"FACILITY",U,"A/R ACCOUNT",U,"ITEM",U,"SCHEDULE#",U,"CHECK#",U,"CHECK AMOUNT"  ;IHS/SD/SDR bar*1.8*6 DD item 4.1.2, SCR 118

 S DUZ(2)=""

 F  S DUZ(2)=$O(^XTMP("BARUFUT6",$J,DUZ(2))) Q:'DUZ(2)  D

 .S FACILITY=$$GET1^DIQ(4,DUZ(2)_",",.01,"E")

 .S IPAC=""

 .F  S IPAC=$O(^XTMP("BARUFUT6",$J,DUZ(2),IPAC)) Q:IPAC=""  D

 ..S ARCOL=""

 ..F  S ARCOL=$O(^XTMP("BARUFUT6",$J,DUZ(2),IPAC,ARCOL)) Q:ARCOL=""  D

 ...S ARCOLNM=$$GET1^DIQ(90051.01,ARCOL_",",.01,"E")

 ...S ARSTAT=$$GET1^DIQ(90051.01,ARCOL_",",3,"E")

 ...S HREC=ARCOLNM  ;collection batch

 ...S HREC=HREC_U_ARSTAT  ;status

 ...S HREC=HREC_U_FACILITY  ;facility

 ...S (ARACCT,ITEMSTAT,CREDDEB)="NO ITEM#"

 ...S ARITEM=""

 ...F  S ARITEM=$O(^XTMP("BARUFUT6",$J,DUZ(2),IPAC,ARCOL,ARITEM)) Q:ARITEM=""  D

 ....S:ARITEM'["MISS" ARACCT=$$GET1^DIQ(90051.1101,ARITEM_","_ARCOL_",",7,"E")

 ....S:ARITEM'["MISS" ITEMSTAT=$$GET1^DIQ(90051.1101,ARITEM_","_ARCOL_",",17,"E")

 ....S REC=HREC_U_ARACCT  ;A/R account

 ....S:ARITEM'["MISS" CREDDEB=$$GET1^DIQ(90051.1101,ARITEM_","_ARCOL_",",102.5,"E")

 ....;start new code IHS/SD/SDR bar*1.8*6 DD 4.1.2

 ....S:ARITEM'["MISS" BARCKN=$$GET1^DIQ(90051.1101,ARITEM_","_ARCOL_",",11,"E")

 ....S:ARITEM'["MISS" BARCKAMT=$$GET1^DIQ(90051.1101,ARITEM_","_ARCOL_",",101,"E")

 ....;end new code IHS/SD/SDR DD 4.1.2

 ....S REC=REC_U_ARITEM  ;item

 ....S REC=REC_U_IPAC  ;sched#

 ....;S REC=REC_U_CREDDEB  ;credit-debit  SCR118

 ....;S REC=REC_U_ITEMSTAT  ;item status  ;bar*1.8*4 SCR83

 ....;start new code IHS/SD/SDR bar*1.8*6 DD 4.1.2

 ....S REC=REC_U_BARCKN  ;check number

 ....S REC=REC_U_BARCKAMT  ;check amount

 ....;end new code DD 4.1.2

 ....W !,REC

 D CLOSE^%ZISH("FILE")

BARUFUT6  ; IHS/SD/TPF - UTILITIES FOR UFMS - PRINT BATCHES WITH SCHEDULE NUMBER POPULATED ;04/10/08

 +1       ;;1.8;IHS ACCOUNTS RECEIVABLE;**4,23**;OCT 26, 2005

 +2       ;NEW ROUTINE BAR*1.8*4 SCR80 4.1.2

 +3       ;

 +4       ; IHS/SD/SDR - v1.8 p6 - DD item 4.1.2

 +5       ;   added fields check# and check amt

 +6        QUIT

 +7       ;

EN        ;EP - PRINT OUT BATCH AND ITEM WITH SCHEDULE NUMBER POPULATED

 +1        NEW BARCOL,BARITEM,IPAC,DUZ2,TEMPDUZ2,CREDDEB,TRDATE,IPACX

 +2       ;

 +3        WRITE !!,"This report will go through A/R payment transactions posted from 10/1/07 forward"

 +4        WRITE !,"and print collection batch information about every batch that was posted to."

 +5        WRITE !

 +6       ;

 +7        KILL DIR

 +8        SET DIR(0)="FO"

 +9        SET DIR("A")="Enter path"

 +10       DO ^DIR

           KILL DIR

 +11       IF $DATA(DTOUT)!$DATA(DIROUT)!$DATA(DUOUT)!(Y="")

               QUIT

 +12       SET PATH=Y

 +13       SET DIR(0)="FO"

 +14       SET DIR("A")="Enter filename"

 +15       DO ^DIR

           KILL DIR

 +16       IF $DATA(DTOUT)!$DATA(DIROUT)!$DATA(DUOUT)!(Y="")

               GOTO EN

 +17       SET FILENAME=Y

 +18      ;

 +19       KILL ^XTMP("BARUFUT6",$JOB)

 +20       SET TEMPDUZ2=DUZ(2)

 +21       SET DUZ(2)=1

 +22       FOR

               SET DUZ(2)=$ORDER(^BARTR(DUZ(2)))

               IF 'DUZ(2)

                   QUIT

               Begin DoDot:1

 +23      ;PULL ONLY TRANSACTIONS FROM 10/1/2007 AND AFTER

                   SET TRDATE=3070930.999999

 +24               FOR

                       SET TRDATE=$ORDER(^BARTR(DUZ(2),TRDATE))

                       IF 'TRDATE

                           QUIT

                       Begin DoDot:2

 +25      ;DO ONLY IHS SITES

                           IF '$$IHS^BARUFUT(DUZ(2))

                               QUIT

 +26      ;;;Q:'$$IHSERA^BARUFUT(DUZ(2))  ;P.OTT DO ONLY IHS SITES AND TRIBAL WITH FLAG

 +27      ;A/R TRANSACTIONS, TRANS TYPE'=PAYMENT

                           IF $$GET1^DIQ(90050.03,TRDATE_",",101,"E")'="PAYMENT"

                               QUIT

 +28      ;A/R TRANSACTIONS, A/R COLLECTION BATCH PTR

                           SET BARCOL=$$GET1^DIQ(90050.03,TRDATE_",",14,"I")

 +29      ;NO COLLECTION BATCH

                           IF 'BARCOL

                               QUIT

 +30      ;A/R TRANSACTIONS, A/R COLLECTION ITEM NUMBER

                           SET BARITEM=$$GET1^DIQ(90050.03,TRDATE_",",15,"I")

 +31      ;NO ITEM NUMBER

                           IF BARITEM=""

                               Begin DoDot:3

 +32                               SET ^XTMP("BARUFUT6",$JOB,DUZ(2),"NO ITEM#",BARCOL,"MISSING",TRDATE)=""

                               End DoDot:3

                               QUIT

 +33                       SET IPAC=$$GET1^DIQ(90051.1101,BARITEM_","_BARCOL_",",20,"E")

 +34                       IF '$$GOODIPAC^BARUFEX3(IPAC)

                               SET IPAC="BAD TDN: "_IPAC

 +35                       SET ^XTMP("BARUFUT6",$JOB,DUZ(2),IPAC,BARCOL,BARITEM)=TRDATE

                       End DoDot:2

               End DoDot:1

 +36       IF '$DATA(^XTMP("BARUFUT6",$JOB))

               WRITE !!,"NO DATA FOUND."

               HANG 3

               GOTO EN

 +37       DO PRINT

 +38       IF $GET(POP)

               WRITE !!,"COULD NOT OPEN FILE!! TRY AGAIN."

               HANG 3

               GOTO EN

 +39       SET DUZ(2)=TEMPDUZ2

 +40       QUIT

 +41      ;

PRINT     ;EP - PRINT

 +1        NEW FACILITY,TRDATE,IPAC,ARCOL,COL,ARCOLNM,ARSTAT

 +2        NEW CREDDEB,ARITEM,CNT,ARACCT,ITEMSTAT

 +3        KILL POP

 +4        DO OPEN^%ZISH("FILE",PATH,FILENAME,"W")

 +5        IF $GET(POP)

               QUIT

 +6       ;W !,"COLLECTION BATCH",U,"STATUS",U,"FACILITY",U,"A/R ACCOUNT",U,"ITEM",U,"SCHEDULE#",U,"CREDIT-DEBIT"  ;bar*1.8*4 SCR83  ;IHS/SD/SDR bar*1.8*6 DD item 4.1.2

 +7       ;IHS/SD/SDR bar*1.8*6 DD item 4.1.2, SCR 118

           WRITE !,"COLLECTION BATCH",U,"STATUS",U,"FACILITY",U,"A/R ACCOUNT",U,"ITEM",U,"SCHEDULE#",U,"CHECK#",U,"CHECK AMOUNT"

 +8        SET DUZ(2)=""

 +9        FOR

               SET DUZ(2)=$ORDER(^XTMP("BARUFUT6",$JOB,DUZ(2)))

               IF 'DUZ(2)

                   QUIT

               Begin DoDot:1

 +10               SET FACILITY=$$GET1^DIQ(4,DUZ(2)_",",.01,"E")

 +11               SET IPAC=""

 +12               FOR

                       SET IPAC=$ORDER(^XTMP("BARUFUT6",$JOB,DUZ(2),IPAC))

                       IF IPAC=""

                           QUIT

                       Begin DoDot:2

 +13                       SET ARCOL=""

 +14                       FOR

                               SET ARCOL=$ORDER(^XTMP("BARUFUT6",$JOB,DUZ(2),IPAC,ARCOL))

                               IF ARCOL=""

                                   QUIT

                               Begin DoDot:3

 +15                               SET ARCOLNM=$$GET1^DIQ(90051.01,ARCOL_",",.01,"E")

 +16                               SET ARSTAT=$$GET1^DIQ(90051.01,ARCOL_",",3,"E")

 +17      ;collection batch

                                   SET HREC=ARCOLNM

 +18      ;status

                                   SET HREC=HREC_U_ARSTAT

 +19      ;facility

                                   SET HREC=HREC_U_FACILITY

 +20                               SET (ARACCT,ITEMSTAT,CREDDEB)="NO ITEM#"

 +21                               SET ARITEM=""

 +22                               FOR

                                       SET ARITEM=$ORDER(^XTMP("BARUFUT6",$JOB,DUZ(2),IPAC,ARCOL,ARITEM))

                                       IF ARITEM=""

                                           QUIT

                                       Begin DoDot:4

 +23                                       IF ARITEM'["MISS"

                                               SET ARACCT=$$GET1^DIQ(90051.1101,ARITEM_","_ARCOL_",",7,"E")

 +24                                       IF ARITEM'["MISS"

                                               SET ITEMSTAT=$$GET1^DIQ(90051.1101,ARITEM_","_ARCOL_",",17,"E")

 +25      ;A/R account

                                           SET REC=HREC_U_ARACCT

 +26                                       IF ARITEM'["MISS"

                                               SET CREDDEB=$$GET1^DIQ(90051.1101,ARITEM_","_ARCOL_",",102.5,"E")

 +27      ;start new code IHS/SD/SDR bar*1.8*6 DD 4.1.2

 +28                                       IF ARITEM'["MISS"

                                               SET BARCKN=$$GET1^DIQ(90051.1101,ARITEM_","_ARCOL_",",11,"E")

 +29                                       IF ARITEM'["MISS"

                                               SET BARCKAMT=$$GET1^DIQ(90051.1101,ARITEM_","_ARCOL_",",101,"E")

 +30      ;end new code IHS/SD/SDR DD 4.1.2

 +31      ;item

                                           SET REC=REC_U_ARITEM

 +32      ;sched#

                                           SET REC=REC_U_IPAC

 +33      ;S REC=REC_U_CREDDEB  ;credit-debit  SCR118

 +34      ;S REC=REC_U_ITEMSTAT  ;item status  ;bar*1.8*4 SCR83

 +35      ;start new code IHS/SD/SDR bar*1.8*6 DD 4.1.2

 +36      ;check number

                                           SET REC=REC_U_BARCKN

 +37      ;check amount

                                           SET REC=REC_U_BARCKAMT

 +38      ;end new code DD 4.1.2

 +39                                       WRITE !,REC

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +40       DO CLOSE^%ZISH("FILE")

 +41       QUIT

BARUFUT6.m