BARRTBSL.m

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_","