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
Q
;
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
Q
;
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")
Q
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
