BARRTBSL ; IHS/SD/TPF - TREASURY DEPOSIT/BATCH STATISTICAL LISTING RPT ;08/20/2008
;;1.8;IHS ACCOUNTS RECEIVABLE;**6,19**;OCT 26, 2005
;
; SDD V1.8 PATCH 6 ITEM 4.1.4
;
;IHS/SD/AR BAR 1.8, PATCH 19 04/20/2010
; IHS/SD/PKD BAR 1.8*19 7/30/10 - Routine too long per SAC - create addt'l routine BARRTBS1
;
ASKTYPE ;EP - ASK WHETHER WANT BATCH OR TRANXN RANGE
D ^XBFMK
W !!
K DIR
S DIR(0)="SA^1:BATCH;2:TRANSACTION"
S DIR("A")="Enter date type (Batch/Transaction): "
D ^DIR
W !!
Q:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
Q:X=""!(X[U)
N DATETYPE
S DATETYPE=Y
I Y=1 D ASKBFROM
I Y=2 D ASKTFROM
Q:$D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
Q:X=""!(X[U)
G ASKSORT
ASKTFROM ;EP - ASK FROM TRANSACTION DATE
N ALLOW,SORTTYP
K %DT
S %DT="AET"
S %DT("A")="Enter beginning POSTING TRANSACTION date: "
W !
D ^%DT
Q:X=""!(X[U)
I Y<0 W !,"INVALID DATE. TRY AGAIN!" H 2 G ASKTFROM
S BARFROM=Y
ASKTTO ;EP - ASK TO TRANSACTION DATE
K %DT
S %DT="AET"
S %DT("A")="Enter ending POSTING TRANSACTION date: "
W !
D ^%DT
Q:X=""!(X[U)
I Y<0 W !,"INVALID DATE. TRY AGAIN!" H 2 G ASKTTO
S BARTO=Y
I BARTO<BARFROM W !!,"END DATE MUST BE GREATER THAN BEGINING DATE" H 2 G ASKTFROM
Q
ASKBFROM ;EP - ASK FROM BATCH DATE
N ALLOW,SORTTYP
K %DT
S %DT="AET"
S %DT("A")="Enter beginning batch open date: "
W !
D ^%DT
Q:X=""!(X[U)
I Y<0 W !,"INVALID DATE. TRY AGAIN!" H 2 G ASKBFROM
S BARFROM=Y
ASKBTO ;EP - ASK TO BATCH DATE
K %DT
S %DT="AET"
S %DT("A")="Enter ending batch open date: "
W !
D ^%DT
Q:X=""!(X[U)
I Y<0 W !,"INVALID DATE. TRY AGAIN!" H 2 G ASKBTO
S BARTO=Y
I BARTO<BARFROM W !!,"END DATE MUST BE GREATER THAN BEGINING DATE" H 2 G ASKBFROM
Q
;IHS/SD/AR BAR 1.8, PATCH 19 04/20/2010
;
ASKSORT ;EP - ASK USER TO SORT BY
K DIR
;IHS/SD/AR BAR 1.8, PATCH 19 04/20/2010
;S DIR(0)="SO^1:ALLOWANCE CATEGORY;2:TDN/IPAC NUMBER"
;S DIR("A")="Sort Report by:"
S DIR(0)="SO^1:ALLOWANCE CATEGORY;2:TDN/IPAC NUMBER;3:BOTH ALLOWANCE CATEGORY AND TDN/IPAC NUMBER SORTED BY ALLOWANCE CATEGORY;4:BOTH TDN/IPAC NUMBER AND ALLOWANCE CATEGORY SORTED BY TDN/IPAC THEN BY ALLOWANCE CATEGORY, SUBTOTAL BY TDN/IPAC"
S DIR("A")="Sort Report by:"
S DIR("L",1)="Select one of the following:"
S DIR("L",2)=""
S DIR("L",3)=" 1 ALLOWANCE CATEGORY"
S DIR("L",4)=" 2 TDN/IPAC NUMBER"
;IHS/SD/AR BAR 1.8, PATCH 19 04/20/2010
S DIR("L",5)=" 3 BOTH ALLOWANCE CATEGORY AND TDN/IPAC NUMBER"
S DIR("L",6)=" SORTED BY ALLOWANCE CATEGORY THEN BY TDN/IPAC, SUBTOTAL"
S DIR("L",7)=" BY ALLOWANCE CATEGORY"
S DIR("L",8)=" 4 BOTH TDN/IPAC NUMBER AND ALLOWANCE CATEGORY"
S DIR("L",9)=" SORTED BY TDN/IPAC THEN BY ALLOWANCE CATEGORY, SUBTOTAL BY TDN/IPAC"
S DIR("B")=1
D ^DIR
G:$D(DTOUT)!$D(DIROUT)!$D(DUOUT)!(Y="") ASKTYPE
;
N BARSORT
S BARSORT=X
I (X=1)!(X=3)!(X=4) D ASKALLOW(.ALLOW) ;GET LIST OF ALLOWANCES TO PULL
;
ASKDEV ;EP - ASK DEVICE
S %ZIS="AQ"
W !
D ^%ZIS
;IHS/SD/AR PATCH 19 06/03/2010
;G:POP ASKFROM
;I $D(IO("Q")) D QUE G ASKFROM
G:POP ASKTYPE
I $D(IO("Q")) D QUE G ASKTYPE
U IO
;IHS/SD/AR PATCH 18 04/20/2010
;D SORT
D:(DATETYPE=1) SORT
D:(DATETYPE=2) TRANSORT
;D:DATETYPE=1 BATSET ;THESE CREATE THE BILLS GLOBAL
;D:DATETYPE=2 TRANSET
;D:BARSORT=3 ALLOW SORT NO ITEMS
;D:BARSORT=4 TDN SORT NO ITEMS
I '$D(^XTMP("BARRTBSL",$J)) D G ASKTYPE
.W !!,"THERE IS NO DATA TO PRINT"
.K DIR
.S DIR(0)="E"
.D ^DIR
;
D:(BARSORT=1)!(BARSORT=2) PRINT
D:(BARSORT>2) PRINTNI^BARRTBS1
;D PRINT
D ^%ZISC
D HOME^%ZIS
;IHS/SD/AR PATCH 19 06/03/2010
;G ASKFROM
G ASKTYPE
Q
;
SORTQ ;EP - ENTRY FROM TASK MAN
D SORT
I '$D(^XTMP("BARRTBSL",$J)) D Q
.D TOPHDR
.W !!,"THERE IS NO DATA TO PRINT"
D PRINT
Q
;
QUE ; EP - QUE THE BARRTBSL REPORT
S ZTRTN="SORTQ^BARRTBSL"
S ZTDESC="BATCH STATISTICAL REPORT (TBSL)"
S ZTSAVE("BARTO")=""
S ZTSAVE("BARFROM")=""
S ZTSAVE("ALLOW")=""
D ^%ZTLOAD
I $D(ZTSK)[0 W !!?5,"Report Cancelled!"
E W !!?5,"Report task #: ",$G(ZTSK)
D HOME^%ZIS
Q
;
ASKALLOW(ALLOW) ;EP - ASK LIST OF ALLOWANCES TO PULL
N DONE,LIST
;GET LIST OF ALLOWANCE CATEGORIES
S LIST=$P($G(^DD(90051.02,7,0)),U,3)_"ALL:ALL CATEGORIES"
K DIR
S DIR(0)="SO^"_LIST
S DIR("A")="Include Which Allowance Categories"
S DIR("B")="ALL"
S DONE=0
F D Q:DONE
.I $O(ALLOW("")) W !!,"You have chosen the following:"
.S A=""
.F S A=$O(ALLOW(A)) Q:A="" D
..W !?30,A
.D ^DIR
.I Y'="ALL" K DIR("B")
.I $D(DTOUT)!$D(DIROUT)!$D(DUOUT)!(Y="") S DONE=1 Q
.S ALLOW(Y)=""
.I Y="ALL" K ALLOW S ALLOW="ALL",DONE=1
I '$D(ALLOW) S ALLOW="ALL"
Q
;
TOPHDR ;EP - TOP HEADER
D TOPHDR^BARRTBS1
Q
;
ITEMHDR ;EP - ITEM HEADER
;W !,"BATCH DATE"
;IHS/SD/AR PATCH 19 06/04/2010
D ITEMHDR^BARRTBS1
Q
;
DATACHEK D DATACHEK^BARRTBS1 ; moved code to shorten routine
Q
;
PRINT D PRINT^BARRTBS1
Q
;
;IHS/SD/AR PATCH 19 06/03/2010
TRANSORT ;
;SORT BY ALLOWANCE CAT, THEN TDN, SUBT TDN, SUBT ALLOW
N DATETIME,BARCOLDA,BARITMDA,ALLOWCAT,COLLIDDA,COLLIDNM,BATCHNM,COLIENS,NOW,SORTSUB2
N ITEMIENS,ITMTDN,ITEMTOT,ITMPSTOT,ITMUNALL,ITMREFUN,ITMPSBAL,SORTSUB,END,BATSTAT
K ^XTMP("BARRTBSL",$J)
S DATETIME=BARFROM-.01
S END=BARTO_".999999"
S BATCHNM=""
;F S DATETIME=$O(^BARCOL(DUZ(2),"C",DATETIME)) Q:'DATETIME!(DATETIME>END) D
F S DATETIME=$O(^BARTR(DUZ(2),"B",DATETIME)) Q:'DATETIME!(DATETIME>END) D
.S BATCHNM=$$GET1^DIQ(90050.03,DATETIME,14) ;A/R COLLECTION BATCH NAME
.Q:BATCHNM=""
.S BARCOLDA=""
.F S BARCOLDA=$O(^BARCOL(DUZ(2),"B",BATCHNM,BARCOLDA)) Q:'BARCOLDA D
..S COLIENS=BARCOLDA_","
..;S BATCHNM=$P($$GET1^DIQ(90051.01,COLIENS,.01,"E"),"-",2,999)_"-" ;A/R COLLECTION BATCH NAME
..;S BATCHNM=$$GET1^DIQ(90051.01,COLIENS,.01,"E") ;A/R COLLECTION BATCH NAME
..S COLLIDDA=$$GET1^DIQ(90051.01,COLIENS,2,"I") ;A/R COLLECTION POINT PTR
..S COLLIDNA=$$GET1^DIQ(90051.01,COLIENS,2,"E") ;A/R COLLECTION POINT NAME
..S ALLOWCAT=$$GET1^DIQ(90051.02,COLLIDDA_",",7,"I") ;ALLOWANCE CATEGORY
..S:ALLOWCAT="" ALLOWCAT="NULL" ;'MCR' FOR Medicare;
..; ;'MCD' FOR Medicaid;
..; ;'PVT' FOR Private Insurance;
..; ;'OTH' FOR Other;
..S BATSTAT=$$GET1^DIQ(90051.01,COLIENS,3,"I") ;BATCH STATUS
..;
..I $D(ALLOW)=10,('$D(ALLOW(ALLOWCAT))) Q ;SCREEN OUT UNCHOSEN ALLOWANCE CATEGORIES
..S BATCHTDN=$$GET1^DIQ(90051.01,COLIENS,28,"E") ;BATCH LEVEL 'TREASURY DEPOSIT NUMBER/IPAC
..S:BATCHTDN="" BATCHTDN="NULL"
..;IHS/SD/AR PATCH 19 06/04/2010
..S BATDNDT=$$GET1^DIQ(90051.01,COLIENS,30) ;BATCH LEVEL TDN DATE
..S:BATDNDT="" BATDNDT="NULL"
..;IHS/SD/AR PATCH 19 06/04/2010
..S BARITMDA=0
..F S BARITMDA=$O(^BARCOL(DUZ(2),BARCOLDA,1,BARITMDA)) Q:'BARITMDA D
...S ITEMIENS=BARITMDA_","_BARCOLDA_","
...S BARSTAT=$$GET1^DIQ(90051.1101,ITEMIENS,17,"I") ;ITEM STATUS 'C' = CANCELLED, 'R' ROLLED OVER
...Q:BARSTAT="R"!(BARSTAT="C")
...S ITMTDN=$$GET1^DIQ(90051.1101,ITEMIENS,20,"E") ;ITEM LEVEL 'TREASURY DEPOSIT NUMBER/IPAC
...S:ITMTDN="" ITMTDN="NULL"
...S ITEMTOT=$$GET1^DIQ(90051.1101,ITEMIENS,102.5,"E") ;CREDIT-DEBIT
...S ITMPSTOT=$$GET1^DIQ(90051.1101,ITEMIENS,18,"E") ;ITEM POSTING TOTAL
...S ITMUNTRU=$$GET1^DIQ(90051.1101,ITEMIENS,105,"E") ;TRUE ITEM UN-ALLOCATED
...S ITMUNTOT=$$GET1^DIQ(90051.1101,ITEMIENS,105.5,"E") ;ITEM TOTAL UN-ALLOCATED
...S ITMREFUN=$$GET1^DIQ(90051.1101,ITEMIENS,106,"E") ;ITEM REFUNDED
...S ITMTOTTR=$$GET1^DIQ(90051.1101,ITEMIENS,22,"E") ;ITEM TOTAL TRANSFER
...S ITMPSBAL=$$GET1^DIQ(90051.1101,ITEMIENS,19,"E") ;ITEM POSTING BALANCE
...;IHS/SD/AR PATCH 19 06/06/10
...;I $D(ALLOW) S SORTSUB=ALLOWCAT,SORTTYP="ALLOW"
...;E S SORTSUB=$S(BATCHTDN'="NULL":BATCHTDN,1:ITMTDN),SORTTYP="TDN"
...I (BARSORT=1)!(BARSORT=3) S SORTSUB=ALLOWCAT,SORTTYP="ALLOW",SORTSUB2=BATCHTDN
...E S SORTSUB=$S(BATCHTDN'="NULL":BATCHTDN,1:ITMTDN),SORTTYP="TDN",SORTSUB2=ALLOWCAT
...;IHS/SD/AR PATCH 19 06/04/2010
...;S ^XTMP("BARRTBSL",$J,SORTSUB,BATCHNM,BARITMDA)=COLLIDNA_U_$S(BATCHTDN'="NULL":BATCHTDN_"~",1:ITMTDN)_U_ITEMTOT_U_ITMPSTOT_U_ITMUNTRU_U_ITMUNTOT_U_ITMREFUN_U_ITMTOTTR_U_ITMPSBAL_U_BATSTAT Q
...I (BARSORT<3) D
....S ^XTMP("BARRTBSL",$J,SORTSUB,BATCHNM,BARITMDA)=COLLIDNA_U_$S(BATCHTDN'="NULL":BATCHTDN_"~",1:ITMTDN)_U_ITEMTOT_U_ITMPSTOT_U_ITMUNTRU_U_ITMUNTOT_U_ITMREFUN_U_ITMTOTTR_U_ITMPSBAL_U_BATSTAT_U_BATDNDT Q
...I (BARSORT>2) D
....S ^XTMP("BARRTBSL",$J,SORTSUB,SORTSUB2,BATDNDT,BATCHNM,BARITMDA)=COLLIDNA_U_$S(BATCHTDN'="NULL":BATCHTDN_"~",1:ITMTDN)_U_ITEMTOT_U_ITMPSTOT_U_ITMUNTRU_U_ITMUNTOT_U_ITMREFUN_U_ITMTOTTR_U_ITMPSBAL_U_BATSTAT Q
Q
;
SORT ;EP- SORT FO TBSL REPORT
N DATETIME,BARCOLDA,BARITMDA,ALLOWCAT,COLLIDDA,COLLIDNM,BATCHNM,COLIENS,NOW,SORTSUB2
N ITEMIENS,ITMTDN,ITEMTOT,ITMPSTOT,ITMUNALL,ITMREFUN,ITMPSBAL,SORTSUB,END,BATSTAT
K ^XTMP("BARRTBSL",$J)
S DATETIME=BARFROM-.01
S END=BARTO_".999999"
F S DATETIME=$O(^BARCOL(DUZ(2),"C",DATETIME)) Q:'DATETIME!(DATETIME>END) D
.S BARCOLDA=""
.F S BARCOLDA=$O(^BARCOL(DUZ(2),"C",DATETIME,BARCOLDA)) Q:'BARCOLDA D
..S COLIENS=BARCOLDA_","
..;S BATCHNM=$P($$GET1^DIQ(90051.01,COLIENS,.01,"E"),"-",2,999)_"-" ;A/R COLLECTION BATCH NAME
..S BATCHNM=$$GET1^DIQ(90051.01,COLIENS,.01,"E") ;A/R COLLECTION BATCH NAME
..S COLLIDDA=$$GET1^DIQ(90051.01,COLIENS,2,"I") ;A/R COLLECTION POINT PTR
..S COLLIDNA=$$GET1^DIQ(90051.01,COLIENS,2,"E") ;A/R COLLECTION POINT NAME
..S ALLOWCAT=$$GET1^DIQ(90051.02,COLLIDDA_",",7,"I") ;ALLOWANCE CATEGORY
..S:ALLOWCAT="" ALLOWCAT="NULL" ;'MCR' FOR Medicare;
..; ;'MCD' FOR Medicaid;
..; ;'PVT' FOR Private Insurance;
..; ;'OTH' FOR Other;
..S BATSTAT=$$GET1^DIQ(90051.01,COLIENS,3,"I") ;BATCH STATUS
..;
..I $D(ALLOW)=10,('$D(ALLOW(ALLOWCAT))) Q ;SCREEN OUT UNCHOSEN ALLOWANCE CATEGORIES
..S BATCHTDN=$$GET1^DIQ(90051.01,COLIENS,28,"E") ;BATCH LEVEL 'TREASURY DEPOSIT NUMBER/IPAC
..S:BATCHTDN="" BATCHTDN="NULL"
..;IHS/SD/AR PATCH 19 06/04/2010
..S BATDNDT=$$GET1^DIQ(90051.01,COLIENS,30) ;BATCH LEVEL TDN DATE
..S:BATDNDT="" BATDNDT="NULL"
..;IHS/SD/AR PATCH 19 06/04/2010
..S BARITMDA=0
..F S BARITMDA=$O(^BARCOL(DUZ(2),BARCOLDA,1,BARITMDA)) Q:'BARITMDA D
...S ITEMIENS=BARITMDA_","_BARCOLDA_","
...S BARSTAT=$$GET1^DIQ(90051.1101,ITEMIENS,17,"I") ;ITEM STATUS 'C' = CANCELLED, 'R' ROLLED OVER
...Q:BARSTAT="R"!(BARSTAT="C")
...S ITMTDN=$$GET1^DIQ(90051.1101,ITEMIENS,20,"E") ;ITEM LEVEL 'TREASURY DEPOSIT NUMBER/IPAC
...S:ITMTDN="" ITMTDN="NULL"
...S ITEMTOT=$$GET1^DIQ(90051.1101,ITEMIENS,102.5,"E") ;CREDIT-DEBIT
...S ITMPSTOT=$$GET1^DIQ(90051.1101,ITEMIENS,18,"E") ;ITEM POSTING TOTAL
...S ITMUNTRU=$$GET1^DIQ(90051.1101,ITEMIENS,105,"E") ;TRUE ITEM UN-ALLOCATED
...S ITMUNTOT=$$GET1^DIQ(90051.1101,ITEMIENS,105.5,"E") ;ITEM TOTAL UN-ALLOCATED
...S ITMREFUN=$$GET1^DIQ(90051.1101,ITEMIENS,106,"E") ;ITEM REFUNDED
...S ITMTOTTR=$$GET1^DIQ(90051.1101,ITEMIENS,22,"E") ;ITEM TOTAL TRANSFER
...S ITMPSBAL=$$GET1^DIQ(90051.1101,ITEMIENS,19,"E") ;ITEM POSTING BALANCE
...;IHS/SD/AR PATCH 19 06/06/10
...;I $D(ALLOW) S SORTSUB=ALLOWCAT,SORTTYP="ALLOW"
...;E S SORTSUB=$S(BATCHTDN'="NULL":BATCHTDN,1:ITMTDN),SORTTYP="TDN"
...I (BARSORT=1)!(BARSORT=3) S SORTSUB=ALLOWCAT,SORTTYP="ALLOW",SORTSUB2=BATCHTDN
...E S SORTSUB=$S(BATCHTDN'="NULL":BATCHTDN,1:ITMTDN),SORTTYP="TDN",SORTSUB2=ALLOWCAT
...;IHS/SD/AR PATCH 19 06/04/2010
...;S ^XTMP("BARRTBSL",$J,SORTSUB,BATCHNM,BARITMDA)=COLLIDNA_U_$S(BATCHTDN'="NULL":BATCHTDN_"~",1:ITMTDN)_U_ITEMTOT_U_ITMPSTOT_U_ITMUNTRU_U_ITMUNTOT_U_ITMREFUN_U_ITMTOTTR_U_ITMPSBAL_U_BATSTAT Q
...I (BARSORT<3) D
....S ^XTMP("BARRTBSL",$J,SORTSUB,BATCHNM,BARITMDA)=COLLIDNA_U_$S(BATCHTDN'="NULL":BATCHTDN_"~",1:ITMTDN)_U_ITEMTOT_U_ITMPSTOT_U_ITMUNTRU_U_ITMUNTOT_U_ITMREFUN_U_ITMTOTTR_U_ITMPSBAL_U_BATSTAT_U_BATDNDT Q
...I (BARSORT>2) D
....S ^XTMP("BARRTBSL",$J,SORTSUB,SORTSUB2,BATDNDT,BATCHNM,BARITMDA)=COLLIDNA_U_$S(BATCHTDN'="NULL":BATCHTDN_"~",1:ITMTDN)_U_ITEMTOT_U_ITMPSTOT_U_ITMUNTRU_U_ITMUNTOT_U_ITMREFUN_U_ITMTOTTR_U_ITMPSBAL_U_BATSTAT Q
Q
;
BARRTBSL ; IHS/SD/TPF - TREASURY DEPOSIT/BATCH STATISTICAL LISTING RPT ;08/20/2008
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**6,19**;OCT 26, 2005
+2 ;
+3 ; SDD V1.8 PATCH 6 ITEM 4.1.4
+4 ;
+5 ;IHS/SD/AR BAR 1.8, PATCH 19 04/20/2010
+6 ; IHS/SD/PKD BAR 1.8*19 7/30/10 - Routine too long per SAC - create addt'l routine BARRTBS1
+7 ;
ASKTYPE ;EP - ASK WHETHER WANT BATCH OR TRANXN RANGE
+1 DO ^XBFMK
+2 WRITE !!
+3 KILL DIR
+4 SET DIR(0)="SA^1:BATCH;2:TRANSACTION"
+5 SET DIR("A")="Enter date type (Batch/Transaction): "
+6 DO ^DIR
+7 WRITE !!
+8 IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT
+9 IF X=""!(X[U)
QUIT
+10 NEW DATETYPE
+11 SET DATETYPE=Y
+12 IF Y=1
DO ASKBFROM
+13 IF Y=2
DO ASKTFROM
+14 IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT
+15 IF X=""!(X[U)
QUIT
+16 GOTO ASKSORT
ASKTFROM ;EP - ASK FROM TRANSACTION DATE
+1 NEW ALLOW,SORTTYP
+2 KILL %DT
+3 SET %DT="AET"
+4 SET %DT("A")="Enter beginning POSTING TRANSACTION date: "
+5 WRITE !
+6 DO ^%DT
+7 IF X=""!(X[U)
QUIT
+8 IF Y<0
WRITE !,"INVALID DATE. TRY AGAIN!"
HANG 2
GOTO ASKTFROM
+9 SET BARFROM=Y
ASKTTO ;EP - ASK TO TRANSACTION DATE
+1 KILL %DT
+2 SET %DT="AET"
+3 SET %DT("A")="Enter ending POSTING TRANSACTION date: "
+4 WRITE !
+5 DO ^%DT
+6 IF X=""!(X[U)
QUIT
+7 IF Y<0
WRITE !,"INVALID DATE. TRY AGAIN!"
HANG 2
GOTO ASKTTO
+8 SET BARTO=Y
+9 IF BARTO<BARFROM
WRITE !!,"END DATE MUST BE GREATER THAN BEGINING DATE"
HANG 2
GOTO ASKTFROM
+10 QUIT
ASKBFROM ;EP - ASK FROM BATCH DATE
+1 NEW ALLOW,SORTTYP
+2 KILL %DT
+3 SET %DT="AET"
+4 SET %DT("A")="Enter beginning batch open date: "
+5 WRITE !
+6 DO ^%DT
+7 IF X=""!(X[U)
QUIT
+8 IF Y<0
WRITE !,"INVALID DATE. TRY AGAIN!"
HANG 2
GOTO ASKBFROM
+9 SET BARFROM=Y
ASKBTO ;EP - ASK TO BATCH DATE
+1 KILL %DT
+2 SET %DT="AET"
+3 SET %DT("A")="Enter ending batch open date: "
+4 WRITE !
+5 DO ^%DT
+6 IF X=""!(X[U)
QUIT
+7 IF Y<0
WRITE !,"INVALID DATE. TRY AGAIN!"
HANG 2
GOTO ASKBTO
+8 SET BARTO=Y
+9 IF BARTO<BARFROM
WRITE !!,"END DATE MUST BE GREATER THAN BEGINING DATE"
HANG 2
GOTO ASKBFROM
+10 QUIT
+11 ;IHS/SD/AR BAR 1.8, PATCH 19 04/20/2010
+12 ;
ASKSORT ;EP - ASK USER TO SORT BY
+1 KILL DIR
+2 ;IHS/SD/AR BAR 1.8, PATCH 19 04/20/2010
+3 ;S DIR(0)="SO^1:ALLOWANCE CATEGORY;2:TDN/IPAC NUMBER"
+4 ;S DIR("A")="Sort Report by:"
+5 SET DIR(0)="SO^1:ALLOWANCE CATEGORY;2:TDN/IPAC NUMBER;3:BOTH ALLOWANCE CATEGORY AND TDN/IPAC NUMBER SORTED BY ALLOWANCE CATEGORY;4:BOTH TDN/IPAC NUMBER AND ALLOWANCE CATEGORY SORTED BY TDN/IPAC THEN BY ALLOWANCE CATEGORY, SUBTOTAL BY TDN/IPAC"
+6 SET DIR("A")="Sort Report by:"
+7 SET DIR("L",1)="Select one of the following:"
+8 SET DIR("L",2)=""
+9 SET DIR("L",3)=" 1 ALLOWANCE CATEGORY"
+10 SET DIR("L",4)=" 2 TDN/IPAC NUMBER"
+11 ;IHS/SD/AR BAR 1.8, PATCH 19 04/20/2010
+12 SET DIR("L",5)=" 3 BOTH ALLOWANCE CATEGORY AND TDN/IPAC NUMBER"
+13 SET DIR("L",6)=" SORTED BY ALLOWANCE CATEGORY THEN BY TDN/IPAC, SUBTOTAL"
+14 SET DIR("L",7)=" BY ALLOWANCE CATEGORY"
+15 SET DIR("L",8)=" 4 BOTH TDN/IPAC NUMBER AND ALLOWANCE CATEGORY"
+16 SET DIR("L",9)=" SORTED BY TDN/IPAC THEN BY ALLOWANCE CATEGORY, SUBTOTAL BY TDN/IPAC"
+17 SET DIR("B")=1
+18 DO ^DIR
+19 IF $DATA(DTOUT)!$DATA(DIROUT)!$DATA(DUOUT)!(Y="")
GOTO ASKTYPE
+20 ;
+21 NEW BARSORT
+22 SET BARSORT=X
+23 ;GET LIST OF ALLOWANCES TO PULL
IF (X=1)!(X=3)!(X=4)
DO ASKALLOW(.ALLOW)
+24 ;
ASKDEV ;EP - ASK DEVICE
+1 SET %ZIS="AQ"
+2 WRITE !
+3 DO ^%ZIS
+4 ;IHS/SD/AR PATCH 19 06/03/2010
+5 ;G:POP ASKFROM
+6 ;I $D(IO("Q")) D QUE G ASKFROM
+7 IF POP
GOTO ASKTYPE
+8 IF $DATA(IO("Q"))
DO QUE
GOTO ASKTYPE
+9 USE IO
+10 ;IHS/SD/AR PATCH 18 04/20/2010
+11 ;D SORT
+12 IF (DATETYPE=1)
DO SORT
+13 IF (DATETYPE=2)
DO TRANSORT
+14 ;D:DATETYPE=1 BATSET ;THESE CREATE THE BILLS GLOBAL
+15 ;D:DATETYPE=2 TRANSET
+16 ;D:BARSORT=3 ALLOW SORT NO ITEMS
+17 ;D:BARSORT=4 TDN SORT NO ITEMS
+18 IF '$DATA(^XTMP("BARRTBSL",$JOB))
Begin DoDot:1
+19 WRITE !!,"THERE IS NO DATA TO PRINT"
+20 KILL DIR
+21 SET DIR(0)="E"
+22 DO ^DIR
End DoDot:1
GOTO ASKTYPE
+23 ;
+24 IF (BARSORT=1)!(BARSORT=2)
DO PRINT
+25 IF (BARSORT>2)
DO PRINTNI^BARRTBS1
+26 ;D PRINT
+27 DO ^%ZISC
+28 DO HOME^%ZIS
+29 ;IHS/SD/AR PATCH 19 06/03/2010
+30 ;G ASKFROM
+31 GOTO ASKTYPE
+32 QUIT
+33 ;
SORTQ ;EP - ENTRY FROM TASK MAN
+1 DO SORT
+2 IF '$DATA(^XTMP("BARRTBSL",$JOB))
Begin DoDot:1
+3 DO TOPHDR
+4 WRITE !!,"THERE IS NO DATA TO PRINT"
End DoDot:1
QUIT
+5 DO PRINT
+6 QUIT
+7 ;
QUE ; EP - QUE THE BARRTBSL REPORT
+1 SET ZTRTN="SORTQ^BARRTBSL"
+2 SET ZTDESC="BATCH STATISTICAL REPORT (TBSL)"
+3 SET ZTSAVE("BARTO")=""
+4 SET ZTSAVE("BARFROM")=""
+5 SET ZTSAVE("ALLOW")=""
+6 DO ^%ZTLOAD
+7 IF $DATA(ZTSK)[0
WRITE !!?5,"Report Cancelled!"
+8 IF '$TEST
WRITE !!?5,"Report task #: ",$GET(ZTSK)
+9 DO HOME^%ZIS
+10 QUIT
+11 ;
ASKALLOW(ALLOW) ;EP - ASK LIST OF ALLOWANCES TO PULL
+1 NEW DONE,LIST
+2 ;GET LIST OF ALLOWANCE CATEGORIES
+3 SET LIST=$PIECE($GET(^DD(90051.02,7,0)),U,3)_"ALL:ALL CATEGORIES"
+4 KILL DIR
+5 SET DIR(0)="SO^"_LIST
+6 SET DIR("A")="Include Which Allowance Categories"
+7 SET DIR("B")="ALL"
+8 SET DONE=0
+9 FOR
Begin DoDot:1
+10 IF $ORDER(ALLOW(""))
WRITE !!,"You have chosen the following:"
+11 SET A=""
+12 FOR
SET A=$ORDER(ALLOW(A))
IF A=""
QUIT
Begin DoDot:2
+13 WRITE !?30,A
End DoDot:2
+14 DO ^DIR
+15 IF Y'="ALL"
KILL DIR("B")
+16 IF $DATA(DTOUT)!$DATA(DIROUT)!$DATA(DUOUT)!(Y="")
SET DONE=1
QUIT
+17 SET ALLOW(Y)=""
+18 IF Y="ALL"
KILL ALLOW
SET ALLOW="ALL"
SET DONE=1
End DoDot:1
IF DONE
QUIT
+19 IF '$DATA(ALLOW)
SET ALLOW="ALL"
+20 QUIT
+21 ;
TOPHDR ;EP - TOP HEADER
+1 DO TOPHDR^BARRTBS1
+2 QUIT
+3 ;
ITEMHDR ;EP - ITEM HEADER
+1 ;W !,"BATCH DATE"
+2 ;IHS/SD/AR PATCH 19 06/04/2010
+3 DO ITEMHDR^BARRTBS1
+4 QUIT
+5 ;
DATACHEK ; moved code to shorten routine
DO DATACHEK^BARRTBS1
+1 QUIT
+2 ;
PRINT DO PRINT^BARRTBS1
+1 QUIT
+2 ;
+3 ;IHS/SD/AR PATCH 19 06/03/2010
TRANSORT ;
+1 ;SORT BY ALLOWANCE CAT, THEN TDN, SUBT TDN, SUBT ALLOW
+2 NEW DATETIME,BARCOLDA,BARITMDA,ALLOWCAT,COLLIDDA,COLLIDNM,BATCHNM,COLIENS,NOW,SORTSUB2
+3 NEW ITEMIENS,ITMTDN,ITEMTOT,ITMPSTOT,ITMUNALL,ITMREFUN,ITMPSBAL,SORTSUB,END,BATSTAT
+4 KILL ^XTMP("BARRTBSL",$JOB)
+5 SET DATETIME=BARFROM-.01
+6 SET END=BARTO_".999999"
+7 SET BATCHNM=""
+8 ;F S DATETIME=$O(^BARCOL(DUZ(2),"C",DATETIME)) Q:'DATETIME!(DATETIME>END) D
+9 FOR
SET DATETIME=$ORDER(^BARTR(DUZ(2),"B",DATETIME))
IF 'DATETIME!(DATETIME>END)
QUIT
Begin DoDot:1
+10 ;A/R COLLECTION BATCH NAME
SET BATCHNM=$$GET1^DIQ(90050.03,DATETIME,14)
+11 IF BATCHNM=""
QUIT
+12 SET BARCOLDA=""
+13 FOR
SET BARCOLDA=$ORDER(^BARCOL(DUZ(2),"B",BATCHNM,BARCOLDA))
IF 'BARCOLDA
QUIT
Begin DoDot:2
+14 SET COLIENS=BARCOLDA_","
+15 ;S BATCHNM=$P($$GET1^DIQ(90051.01,COLIENS,.01,"E"),"-",2,999)_"-" ;A/R COLLECTION BATCH NAME
+16 ;S BATCHNM=$$GET1^DIQ(90051.01,COLIENS,.01,"E") ;A/R COLLECTION BATCH NAME
+17 ;A/R COLLECTION POINT PTR
SET COLLIDDA=$$GET1^DIQ(90051.01,COLIENS,2,"I")
+18 ;A/R COLLECTION POINT NAME
SET COLLIDNA=$$GET1^DIQ(90051.01,COLIENS,2,"E")
+19 ;ALLOWANCE CATEGORY
SET ALLOWCAT=$$GET1^DIQ(90051.02,COLLIDDA_",",7,"I")
+20 ;'MCR' FOR Medicare;
IF ALLOWCAT=""
SET ALLOWCAT="NULL"
+21 ; ;'MCD' FOR Medicaid;
+22 ; ;'PVT' FOR Private Insurance;
+23 ; ;'OTH' FOR Other;
+24 ;BATCH STATUS
SET BATSTAT=$$GET1^DIQ(90051.01,COLIENS,3,"I")
+25 ;
+26 ;SCREEN OUT UNCHOSEN ALLOWANCE CATEGORIES
IF $DATA(ALLOW)=10
IF ('$DATA(ALLOW(ALLOWCAT)))
QUIT
+27 ;BATCH LEVEL 'TREASURY DEPOSIT NUMBER/IPAC
SET BATCHTDN=$$GET1^DIQ(90051.01,COLIENS,28,"E")
+28 IF BATCHTDN=""
SET BATCHTDN="NULL"
+29 ;IHS/SD/AR PATCH 19 06/04/2010
+30 ;BATCH LEVEL TDN DATE
SET BATDNDT=$$GET1^DIQ(90051.01,COLIENS,30)
+31 IF BATDNDT=""
SET BATDNDT="NULL"
+32 ;IHS/SD/AR PATCH 19 06/04/2010
+33 SET BARITMDA=0
+34 FOR
SET BARITMDA=$ORDER(^BARCOL(DUZ(2),BARCOLDA,1,BARITMDA))
IF 'BARITMDA
QUIT
Begin DoDot:3
+35 SET ITEMIENS=BARITMDA_","_BARCOLDA_","
+36 ;ITEM STATUS 'C' = CANCELLED, 'R' ROLLED OVER
SET BARSTAT=$$GET1^DIQ(90051.1101,ITEMIENS,17,"I")
+37 IF BARSTAT="R"!(BARSTAT="C")
QUIT
+38 ;ITEM LEVEL 'TREASURY DEPOSIT NUMBER/IPAC
SET ITMTDN=$$GET1^DIQ(90051.1101,ITEMIENS,20,"E")
+39 IF ITMTDN=""
SET ITMTDN="NULL"
+40 ;CREDIT-DEBIT
SET ITEMTOT=$$GET1^DIQ(90051.1101,ITEMIENS,102.5,"E")
+41 ;ITEM POSTING TOTAL
SET ITMPSTOT=$$GET1^DIQ(90051.1101,ITEMIENS,18,"E")
+42 ;TRUE ITEM UN-ALLOCATED
SET ITMUNTRU=$$GET1^DIQ(90051.1101,ITEMIENS,105,"E")
+43 ;ITEM TOTAL UN-ALLOCATED
SET ITMUNTOT=$$GET1^DIQ(90051.1101,ITEMIENS,105.5,"E")
+44 ;ITEM REFUNDED
SET ITMREFUN=$$GET1^DIQ(90051.1101,ITEMIENS,106,"E")
+45 ;ITEM TOTAL TRANSFER
SET ITMTOTTR=$$GET1^DIQ(90051.1101,ITEMIENS,22,"E")
+46 ;ITEM POSTING BALANCE
SET ITMPSBAL=$$GET1^DIQ(90051.1101,ITEMIENS,19,"E")
+47 ;IHS/SD/AR PATCH 19 06/06/10
+48 ;I $D(ALLOW) S SORTSUB=ALLOWCAT,SORTTYP="ALLOW"
+49 ;E S SORTSUB=$S(BATCHTDN'="NULL":BATCHTDN,1:ITMTDN),SORTTYP="TDN"
+50 IF (BARSORT=1)!(BARSORT=3)
SET SORTSUB=ALLOWCAT
SET SORTTYP="ALLOW"
SET SORTSUB2=BATCHTDN
+51 IF '$TEST
SET SORTSUB=$SELECT(BATCHTDN'="NULL":BATCHTDN,1:ITMTDN)
SET SORTTYP="TDN"
SET SORTSUB2=ALLOWCAT
+52 ;IHS/SD/AR PATCH 19 06/04/2010
+53 ;S ^XTMP("BARRTBSL",$J,SORTSUB,BATCHNM,BARITMDA)=COLLIDNA_U_$S(BATCHTDN'="NULL":BATCHTDN_"~",1:ITMTDN)_U_ITEMTOT_U_ITMPSTOT_U_ITMUNTRU_U_ITMUNTOT_U_ITMREFUN_U_ITMTOTTR_U_ITMPSBAL_U_BATSTAT Q
+54 IF (BARSORT<3)
Begin DoDot:4
+55 SET ^XTMP("BARRTBSL",$JOB,SORTSUB,BATCHNM,BARITMDA)=COLLIDNA_U_$SELECT(BATCHTDN'="NULL":BATCHTDN_"~",1:ITMTDN)_U_ITEMTOT_U_ITMPSTOT_U_ITMUNTRU_U_ITMUNTOT_U_ITMREFUN_U_ITMTOTTR_U_ITMPSBAL_U_BATSTAT_U_BATDNDT
QUIT
End DoDot:4
+56 IF (BARSORT>2)
Begin DoDot:4
+57 SET ^XTMP("BARRTBSL",$JOB,SORTSUB,SORTSUB2,BATDNDT,BATCHNM,BARITMDA)=COLLIDNA_U_$SELECT(BATCHTDN'="NULL":BATCHTDN_"~",1:ITMTDN)_U_ITEMTOT_U_ITMPSTOT_U_ITMUNTRU_U_ITMUNTOT_U_ITMREFUN_U_ITMTOTTR_U_ITMPSBAL_U_BATSTA
T
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+58 QUIT
+59 ;
SORT ;EP- SORT FO TBSL REPORT
+1 NEW DATETIME,BARCOLDA,BARITMDA,ALLOWCAT,COLLIDDA,COLLIDNM,BATCHNM,COLIENS,NOW,SORTSUB2
+2 NEW ITEMIENS,ITMTDN,ITEMTOT,ITMPSTOT,ITMUNALL,ITMREFUN,ITMPSBAL,SORTSUB,END,BATSTAT
+3 KILL ^XTMP("BARRTBSL",$JOB)
+4 SET DATETIME=BARFROM-.01
+5 SET END=BARTO_".999999"
+6 FOR
SET DATETIME=$ORDER(^BARCOL(DUZ(2),"C",DATETIME))
IF 'DATETIME!(DATETIME>END)
QUIT
Begin DoDot:1
+7 SET BARCOLDA=""
+8 FOR
SET BARCOLDA=$ORDER(^BARCOL(DUZ(2),"C",DATETIME,BARCOLDA))
IF 'BARCOLDA
QUIT
Begin DoDot:2
+9 SET COLIENS=BARCOLDA_","
+10 ;S BATCHNM=$P($$GET1^DIQ(90051.01,COLIENS,.01,"E"),"-",2,999)_"-" ;A/R COLLECTION BATCH NAME
+11 ;A/R COLLECTION BATCH NAME
SET BATCHNM=$$GET1^DIQ(90051.01,COLIENS,.01,"E")
+12 ;A/R COLLECTION POINT PTR
SET COLLIDDA=$$GET1^DIQ(90051.01,COLIENS,2,"I")
+13 ;A/R COLLECTION POINT NAME
SET COLLIDNA=$$GET1^DIQ(90051.01,COLIENS,2,"E")
+14 ;ALLOWANCE CATEGORY
SET ALLOWCAT=$$GET1^DIQ(90051.02,COLLIDDA_",",7,"I")
+15 ;'MCR' FOR Medicare;
IF ALLOWCAT=""
SET ALLOWCAT="NULL"
+16 ; ;'MCD' FOR Medicaid;
+17 ; ;'PVT' FOR Private Insurance;
+18 ; ;'OTH' FOR Other;
+19 ;BATCH STATUS
SET BATSTAT=$$GET1^DIQ(90051.01,COLIENS,3,"I")
+20 ;
+21 ;SCREEN OUT UNCHOSEN ALLOWANCE CATEGORIES
IF $DATA(ALLOW)=10
IF ('$DATA(ALLOW(ALLOWCAT)))
QUIT
+22 ;BATCH LEVEL 'TREASURY DEPOSIT NUMBER/IPAC
SET BATCHTDN=$$GET1^DIQ(90051.01,COLIENS,28,"E")
+23 IF BATCHTDN=""
SET BATCHTDN="NULL"
+24 ;IHS/SD/AR PATCH 19 06/04/2010
+25 ;BATCH LEVEL TDN DATE
SET BATDNDT=$$GET1^DIQ(90051.01,COLIENS,30)
+26 IF BATDNDT=""
SET BATDNDT="NULL"
+27 ;IHS/SD/AR PATCH 19 06/04/2010
+28 SET BARITMDA=0
+29 FOR
SET BARITMDA=$ORDER(^BARCOL(DUZ(2),BARCOLDA,1,BARITMDA))
IF 'BARITMDA
QUIT
Begin DoDot:3
+30 SET ITEMIENS=BARITMDA_","_BARCOLDA_","
+31 ;ITEM STATUS 'C' = CANCELLED, 'R' ROLLED OVER
SET BARSTAT=$$GET1^DIQ(90051.1101,ITEMIENS,17,"I")
+32 IF BARSTAT="R"!(BARSTAT="C")
QUIT
+33 ;ITEM LEVEL 'TREASURY DEPOSIT NUMBER/IPAC
SET ITMTDN=$$GET1^DIQ(90051.1101,ITEMIENS,20,"E")
+34 IF ITMTDN=""
SET ITMTDN="NULL"
+35 ;CREDIT-DEBIT
SET ITEMTOT=$$GET1^DIQ(90051.1101,ITEMIENS,102.5,"E")
+36 ;ITEM POSTING TOTAL
SET ITMPSTOT=$$GET1^DIQ(90051.1101,ITEMIENS,18,"E")
+37 ;TRUE ITEM UN-ALLOCATED
SET ITMUNTRU=$$GET1^DIQ(90051.1101,ITEMIENS,105,"E")
+38 ;ITEM TOTAL UN-ALLOCATED
SET ITMUNTOT=$$GET1^DIQ(90051.1101,ITEMIENS,105.5,"E")
+39 ;ITEM REFUNDED
SET ITMREFUN=$$GET1^DIQ(90051.1101,ITEMIENS,106,"E")
+40 ;ITEM TOTAL TRANSFER
SET ITMTOTTR=$$GET1^DIQ(90051.1101,ITEMIENS,22,"E")
+41 ;ITEM POSTING BALANCE
SET ITMPSBAL=$$GET1^DIQ(90051.1101,ITEMIENS,19,"E")
+42 ;IHS/SD/AR PATCH 19 06/06/10
+43 ;I $D(ALLOW) S SORTSUB=ALLOWCAT,SORTTYP="ALLOW"
+44 ;E S SORTSUB=$S(BATCHTDN'="NULL":BATCHTDN,1:ITMTDN),SORTTYP="TDN"
+45 IF (BARSORT=1)!(BARSORT=3)
SET SORTSUB=ALLOWCAT
SET SORTTYP="ALLOW"
SET SORTSUB2=BATCHTDN
+46 IF '$TEST
SET SORTSUB=$SELECT(BATCHTDN'="NULL":BATCHTDN,1:ITMTDN)
SET SORTTYP="TDN"
SET SORTSUB2=ALLOWCAT
+47 ;IHS/SD/AR PATCH 19 06/04/2010
+48 ;S ^XTMP("BARRTBSL",$J,SORTSUB,BATCHNM,BARITMDA)=COLLIDNA_U_$S(BATCHTDN'="NULL":BATCHTDN_"~",1:ITMTDN)_U_ITEMTOT_U_ITMPSTOT_U_ITMUNTRU_U_ITMUNTOT_U_ITMREFUN_U_ITMTOTTR_U_ITMPSBAL_U_BATSTAT Q
+49 IF (BARSORT<3)
Begin DoDot:4
+50 SET ^XTMP("BARRTBSL",$JOB,SORTSUB,BATCHNM,BARITMDA)=COLLIDNA_U_$SELECT(BATCHTDN'="NULL":BATCHTDN_"~",1:ITMTDN)_U_ITEMTOT_U_ITMPSTOT_U_ITMUNTRU_U_ITMUNTOT_U_ITMREFUN_U_ITMTOTTR_U_ITMPSBAL_U_BATSTAT_U_BATDNDT
QUIT
End DoDot:4
+51 IF (BARSORT>2)
Begin DoDot:4
+52 SET ^XTMP("BARRTBSL",$JOB,SORTSUB,SORTSUB2,BATDNDT,BATCHNM,BARITMDA)=COLLIDNA_U_$SELECT(BATCHTDN'="NULL":BATCHTDN_"~",1:ITMTDN)_U_ITEMTOT_U_ITMPSTOT_U_ITMUNTRU_U_ITMUNTOT_U_ITMREFUN_U_ITMTOTTR_U_ITMPSBAL_U_BATSTA
T
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+53 QUIT
+54 ;
