Routine: BARMPAS3

BARMPAS3 ; IHS/SD/LSL - Patient Account Statement Print ;

 ;;1.8;IHS ACCOUNTS RECEIVABLE;**19,20,21,23**;OCT 26, 2005

 ; IHS/SD/LSL - 05/13/03 - V1.7 Patch 2

 ; ********************************************************************

 ;FEB 2012 PETER OTTIS IHS/SD/OIT LINE PRINT+1 ADDED TO GET REPORT HEADER WHEN PRINTED (QUEUED)

 ;HEAT#80718 21-AUG-2012 P.OTTIS  ADDED SORTING OPTION BY PATNAME

 ;HEAT #91646 DROPPED KILLING COLLECTED DATA (RETAIN DISFUNCT) - WILL BE HANDLED BY THE NEW 'PUR' OPTION

GETHDR  ;EP

  ; Find Patient Account Header

 K DIC,DA,DR

 S DIC="^BAR(90052.03,"              ; A/R Letters & Text File

 S DIC(0)="LX"

 S X="ACCOUNT STATEMENT HEADER"

 D ^DIC

 ; Account Header not found

 I +Y<0 D  Q

 . W !,$$CJ^XLFSTR("ACCOUNT STATEMENT HEADER entry not found in A/R LETTERS & TEXT File",IOM)

 . W !,$$CJ^XLFSTR("Please create the entry before proceeding with this print.",IOM)

 . D EOP^BARUTL(0)

 ; Retrieve and store header in XTMP

 S BARHDRDA=+Y

 D ENP^XBDIQ1(90052.03,BARHDRDA,100,"BARHDR(")

 K BARHDR("ID")

 K ^XTMP("BARPAS"_BARRUNDT,"HDR")

 M ^XTMP("BARPAS"_BARRUNDT,"HDR")=BARHDR(100)

 K BARHDR

 ; ********************************************************************

PGHDR ; EP

 ; Print Patient Account header and demographics

 ; Write Billing Office Address

 K BARPT,BARHRN

 S BARPG=BARPG+1

 ; BARPG>1 W !

 ;W @IOF W #

 W $$EN^BARVDF("IOF"),!  ;

 ;W @IOF  ;Original code restored

 S $P(BAREQUAL,"=",IOM-2)=""

 S $P(BARDASH,"-",IOM-2)=""

 D HDR

 ; Gather Patient Demographics

 S BARDFN=$$GET1^DIQ(90050.02,BARACDA,1.001)   ; IEN to Patient file

 S BARPTNM=$$GET1^DIQ(9000001,BARDFN,.01)      ; Patient Name

 S BARPTAGE=$$GET1^DIQ(9000001,BARDFN,1102.99)  ; Patient Age

 S BARADDR=$$GET1^DIQ(9000001,BARDFN,1602.2)   ; Patient street Address

 S BARCITY=$$GET1^DIQ(9000001,BARDFN,1603.2)   ; Patient City

 S BARSTATE=$$GET1^DIQ(2,BARDFN,.115,"I")      ; Patient State IEN

 S:+BARSTATE BARSTATE=$$GET1^DIQ(5,BARSTATE,1)  ; State code

 S BARZIP=$$GET1^DIQ(9000001,BARDFN,1605.2)    ; Patient Zip

 S BARIENS=DUZ(2)_","_BARDFN_","

 S BARHRN=$$GET1^DIQ(9000001.41,BARIENS,.02)   ; Patient Chart number

 ; Write Patient Name and Address

 I BARPTAGE<18 W !,?5,"TO THE PARENTS OF"

 W !?5,BARPTNM

 W ?55,"STATEMENT PERIOD"

 W !?5,BARADDR

 W ?55,$$SDT^BARDUTL(BARDTB)," - ",$$SDT^BARDUTL(BARDTE)

 W !?5,BARCITY,", ",BARSTATE,", ",BARZIP

 W !!!,BAREQUAL

 W !,HL1

 W !,HL2

 W !,BAREQUAL

 ; ********************************************************************

HDR ; EP

 ; Write Billing Office Address

 W !,?2,"Statement Date: ",$$SDT^BARDUTL(DT),?70,"Page: ",BARPG,!

 F I=1:1 Q:'$D(^XTMP("BARPAS"_BARRUNDT,"HDR",I))  W !,^(I)

W !

 ; ********************************************************************

PG(L) ; EP

 I ((IOSL-$Y)<L)&($E(IOST)="P") D PGHDR Q  ; Printer

 Q:IOSL>$Y

  D PAZ^BARRUTL

 I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S BARF1=1 Q

 D PGHDR

 ;end 1.8*20

 ; ********************************************************************

EXIT ; EP

 I AZKILL=0 K ^XTMP("AZLKPS",AZJB)

 K AZJB,AZKILL

 ;IHS/SD/PKD 1.8*19 Moved here from BARMPAS2 due

 ; to size limitations per SAC

PRTASK ; EP

 ; Called from Print Patient Accounts' Statements AR Menu Option

 D SELECT                            ; Select run to Print

 Q:'$D(BARRUNDT)                     ; No run selected

 S BARSRTBY=$G(^XTMP("BARPAS"_BARRUNDT,0,"SORTBY"),-1) ;P.OTT

 I BARSRTBY<0 D  Q

 . W !!,"THIS BATCH OF STATEMENTS IS NOT COMPATIBLE WITH THE NEW FILE STRUCTURE."

 . W !,"WILL RUN REIDEXING FIRST, THEN TRY AGAIN",!!

 . D REINDEX^BARMPAS5("BARPAS"_BARRUNDT)

 . D EOP^BARUTL(0)

. Q

 ;;;D RETAIN                         ; Keep run to print again?

 D GETHDR^BARMPAS3                   ; Get Statement Header

 Q:'$D(BARHDRDA)                     ; Not in A/R Letters and Text File

 S BARQ("RC")="COMPUTE^BARMPAS2"     ; Build tmp global with data

 S BARQ("RP")="PRINT^BARMPAS3"       ; Print reports from tmp global

 S BARQ("NS")="BAR"                  ; Namespace for variables

 S BARQ("RX")="EXIT^BARMPAS2"        ; Clean-up routine

 D GETMSG^BARMPAS

 D ^BARDBQUE                         ; Double queuing

 D PAZ^BARRUTL                       ; Press return to continue

 ; ***

SELECT ;

 K BARRUNDT

 ; Look for data in temp global

 S BAR1=$O(^XTMP("BARPAS"))

 I BAR1'["BARPAS" D  Q

 . W !!!,$$CJ^XLFSTR("NO PATIENT ACCOUNT STATEMENT RUNS TO CHOOSE FROM",IOM)

 . D EOP^BARUTL(0)

 ; Display tasked runs to choose from

 W !,"Select Account Run time:  ",!

 S BARCNT=0

 S BAR1="BARPAS" F  S BAR1=$O(^XTMP(BAR1)) Q:BAR1'["BARPAS"  D

 . S BARCNT=BARCNT+1                           ; Line counter

 . S BARDT=$P(BAR1,"BARPAS",2,99)              ; Date of Run

 . S BARRUN(BARCNT)=BARDT                      ; Array of runs

 . S Y=BARDT

 . D DD^%DT

 . W !,$J(BARCNT,2),?5,Y                       ; Line count,date run

 . I '$D(^XTMP("BARPAS"_BARDT,0,"SORTBY")) W "  not compatible" Q

 . S BARSRTBY=$G(^XTMP("BARPAS"_BARDT,0,"SORTBY"))+1

 . ;;;I BARSRTBY W "  sorted by ",$P("Billing location, Account Number;Billing location, Patient name",";",BARSRTBY)

 ; Select run to print

 K DIR

 S DIR(0)="NO^1:"_BARCNT

 D ^DIR

 I '+Y D  Q

 . W !,"NONE SELECTED",!

 . D EOP^BARUTL(0)

 S BARRUNDT=BARRUN(+Y)

 K BARRUN  ; IHS/SD/PKD 10/12/10 KILL ARRAY

 ; ***

RETAIN ;

 W !,"DO YOU WISH TO RETAIN THE RUN TO PRINT AGAIN ?"

 K DIR

 S DIR(0)="Y"

 S DIR("B")="N"

 D ^DIR

 S BARKILL=Y

 ; ***

PRINT  ;EP

 D GETHDR ;21 FEB 2012 P.OTT IHS/SD/OIT ADDED FOR QUEUED REPORTS

 S BARTMP=$G(^XTMP("BARPAS"_BARRUNDT,0,"DT"))

 S BARSRTBY=$G(^XTMP("BARPAS"_BARRUNDT,0,"SORTBY"),0) ;P.OTT

 S BARDTB=$P(BARTMP,U)                         ; Statement begin date

 S BARDTE=$P(BARTMP,U,2)                       ; Statement end date

 S HL1="        BILLED    INSURANCE     PATIENT   ADJUSTED     INSURANCE    PATIENT"

 S HL2="        AMOUNT     PAYMENT      PAYMENT    AMOUNT     OUTSTANDING  AMOUNT DUE"

 D PRINT^BARMPAS2

PAZ ; Add extra line feeds to force alignment

 ; IHS/SD/PKD copied from PAZ^BARRUTL but for printers

 ; BARRUTL quits if not terminal

 Q  ; IHS/SD/PKD 1.8*20 removed didn't work for network printers

 I '$D(IO("Q")) D

 .F  W ! Q:$Y>(IOSL+3)

BARMPAS3  ; IHS/SD/LSL - Patient Account Statement Print ;

 +1       ;;1.8;IHS ACCOUNTS RECEIVABLE;**19,20,21,23**;OCT 26, 2005

 +2       ;

 +3       ; IHS/SD/LSL - 05/13/03 - V1.7 Patch 2

 +4       ;

 +5       ; ********************************************************************

 +6       ;FEB 2012 PETER OTTIS IHS/SD/OIT LINE PRINT+1 ADDED TO GET REPORT HEADER WHEN PRINTED (QUEUED)

 +7       ;HEAT#80718 21-AUG-2012 P.OTTIS  ADDED SORTING OPTION BY PATNAME

 +8       ;HEAT #91646 DROPPED KILLING COLLECTED DATA (RETAIN DISFUNCT) - WILL BE HANDLED BY THE NEW 'PUR' OPTION

 +9        QUIT

 +10      ;

GETHDR    ;EP

 +1       ; Find Patient Account Header

 +2        KILL DIC,DA,DR

 +3       ; A/R Letters & Text File

           SET DIC="^BAR(90052.03,"

 +4        SET DIC(0)="LX"

 +5        SET X="ACCOUNT STATEMENT HEADER"

 +6        DO ^DIC

 +7       ;

 +8       ; Account Header not found

 +9        IF +Y<0

               Begin DoDot:1

 +10               WRITE !,$$CJ^XLFSTR("ACCOUNT STATEMENT HEADER entry not found in A/R LETTERS & TEXT File",IOM)

 +11               WRITE !,$$CJ^XLFSTR("Please create the entry before proceeding with this print.",IOM)

 +12               DO EOP^BARUTL(0)

               End DoDot:1

               QUIT

 +13      ;

 +14      ; Retrieve and store header in XTMP

 +15       SET BARHDRDA=+Y

 +16       DO ENP^XBDIQ1(90052.03,BARHDRDA,100,"BARHDR(")

 +17       KILL BARHDR("ID")

 +18       KILL ^XTMP("BARPAS"_BARRUNDT,"HDR")

 +19       MERGE ^XTMP("BARPAS"_BARRUNDT,"HDR")=BARHDR(100)

 +20       KILL BARHDR

 +21       QUIT

 +22      ; ********************************************************************

 +23      ;

PGHDR     ; EP

 +1       ; Print Patient Account header and demographics

 +2       ; Write Billing Office Address

 +3        KILL BARPT,BARHRN

 +4        SET BARPG=BARPG+1

 +5       ; BARPG>1 W !

 +6       ;W @IOF W #

 +7       ;

           WRITE $$EN^BARVDF("IOF"),!

 +8       ;W @IOF  ;Original code restored

 +9        SET $PIECE(BAREQUAL,"=",IOM-2)=""

 +10       SET $PIECE(BARDASH,"-",IOM-2)=""

 +11       DO HDR

 +12      ;

 +13      ; Gather Patient Demographics

 +14      ; IEN to Patient file

           SET BARDFN=$$GET1^DIQ(90050.02,BARACDA,1.001)

 +15      ; Patient Name

           SET BARPTNM=$$GET1^DIQ(9000001,BARDFN,.01)

 +16      ; Patient Age

           SET BARPTAGE=$$GET1^DIQ(9000001,BARDFN,1102.99)

 +17      ; Patient street Address

           SET BARADDR=$$GET1^DIQ(9000001,BARDFN,1602.2)

 +18      ; Patient City

           SET BARCITY=$$GET1^DIQ(9000001,BARDFN,1603.2)

 +19      ; Patient State IEN

           SET BARSTATE=$$GET1^DIQ(2,BARDFN,.115,"I")

 +20      ; State code

           IF +BARSTATE

               SET BARSTATE=$$GET1^DIQ(5,BARSTATE,1)

 +21      ; Patient Zip

           SET BARZIP=$$GET1^DIQ(9000001,BARDFN,1605.2)

 +22       SET BARIENS=DUZ(2)_","_BARDFN_","

 +23      ; Patient Chart number

           SET BARHRN=$$GET1^DIQ(9000001.41,BARIENS,.02)

 +24      ;

 +25      ; Write Patient Name and Address

 +26       IF BARPTAGE<18

               WRITE !,?5,"TO THE PARENTS OF"

 +27       WRITE !?5,BARPTNM

 +28       WRITE ?55,"STATEMENT PERIOD"

 +29       WRITE !?5,BARADDR

 +30       WRITE ?55,$$SDT^BARDUTL(BARDTB)," - ",$$SDT^BARDUTL(BARDTE)

 +31       WRITE !?5,BARCITY,", ",BARSTATE,", ",BARZIP

 +32       WRITE !!!,BAREQUAL

 +33       WRITE !,HL1

 +34       WRITE !,HL2

 +35       WRITE !,BAREQUAL

 +36       QUIT

 +37      ; ********************************************************************

 +38      ;

HDR       ; EP

 +1       ; Write Billing Office Address

 +2        WRITE !,?2,"Statement Date: ",$$SDT^BARDUTL(DT),?70,"Page: ",BARPG,!

 +3        FOR I=1:1

               IF '$DATA(^XTMP("BARPAS"_BARRUNDT,"HDR",I))

                   QUIT

               WRITE !,^(I)

 +4        WRITE !

 +5        QUIT

 +6       ; ********************************************************************

 +7       ;

PG(L)     ; EP

 +1       ; Printer

           IF ((IOSL-$Y)<L)&($EXTRACT(IOST)="P")

               DO PGHDR

               QUIT

 +2        IF IOSL>$Y

               QUIT

 +3        DO PAZ^BARRUTL

 +4        IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)

               SET BARF1=1

               QUIT

 +5        DO PGHDR

 +6       ;end 1.8*20

 +7        QUIT

 +8       ; ********************************************************************

 +9       ;

EXIT      ; EP

 +1        IF AZKILL=0

               KILL ^XTMP("AZLKPS",AZJB)

 +2        KILL AZJB,AZKILL

 +3        QUIT

 +4       ;

 +5       ;IHS/SD/PKD 1.8*19 Moved here from BARMPAS2 due

 +6       ; to size limitations per SAC

PRTASK    ; EP

 +1       ; Called from Print Patient Accounts' Statements AR Menu Option

 +2       ; Select run to Print

           DO SELECT

 +3       ; No run selected

           IF '$DATA(BARRUNDT)

               QUIT

 +4       ;P.OTT

           SET BARSRTBY=$GET(^XTMP("BARPAS"_BARRUNDT,0,"SORTBY"),-1)

 +5        IF BARSRTBY<0

               Begin DoDot:1

 +6                WRITE !!,"THIS BATCH OF STATEMENTS IS NOT COMPATIBLE WITH THE NEW FILE STRUCTURE."

 +7                WRITE !,"WILL RUN REIDEXING FIRST, THEN TRY AGAIN",!!

 +8                DO REINDEX^BARMPAS5("BARPAS"_BARRUNDT)

 +9                DO EOP^BARUTL(0)

 +10               QUIT

               End DoDot:1

               QUIT

 +11      ;;;D RETAIN                         ; Keep run to print again?

 +12      ; Get Statement Header

           DO GETHDR^BARMPAS3

 +13      ; Not in A/R Letters and Text File

           IF '$DATA(BARHDRDA)

               QUIT

 +14      ; Build tmp global with data

           SET BARQ("RC")="COMPUTE^BARMPAS2"

 +15      ; Print reports from tmp global

           SET BARQ("RP")="PRINT^BARMPAS3"

 +16      ; Namespace for variables

           SET BARQ("NS")="BAR"

 +17      ; Clean-up routine

           SET BARQ("RX")="EXIT^BARMPAS2"

 +18       DO GETMSG^BARMPAS

 +19      ; Double queuing

           DO ^BARDBQUE

 +20      ; Press return to continue

           DO PAZ^BARRUTL

 +21       QUIT

 +22      ; ***

SELECT    ;

 +1        KILL BARRUNDT

 +2       ; Look for data in temp global

 +3        SET BAR1=$ORDER(^XTMP("BARPAS"))

 +4        IF BAR1'["BARPAS"

               Begin DoDot:1

 +5                WRITE !!!,$$CJ^XLFSTR("NO PATIENT ACCOUNT STATEMENT RUNS TO CHOOSE FROM",IOM)

 +6                DO EOP^BARUTL(0)

               End DoDot:1

               QUIT

 +7       ;

 +8       ; Display tasked runs to choose from

 +9        WRITE !,"Select Account Run time:  ",!

 +10       SET BARCNT=0

 +11       SET BAR1="BARPAS"

FOR

               SET BAR1=$ORDER(^XTMP(BAR1))

               IF BAR1'["BARPAS"

                   QUIT

               Begin DoDot:1

 +12      ; Line counter

                   SET BARCNT=BARCNT+1

 +13      ; Date of Run

                   SET BARDT=$PIECE(BAR1,"BARPAS",2,99)

 +14      ; Array of runs

                   SET BARRUN(BARCNT)=BARDT

 +15               SET Y=BARDT

 +16               DO DD^%DT

 +17      ; Line count,date run

                   WRITE !,$JUSTIFY(BARCNT,2),?5,Y

 +18               IF '$DATA(^XTMP("BARPAS"_BARDT,0,"SORTBY"))

                       WRITE "  not compatible"

                       QUIT

 +19               SET BARSRTBY=$GET(^XTMP("BARPAS"_BARDT,0,"SORTBY"))+1

 +20      ;;;I BARSRTBY W "  sorted by ",$P("Billing location, Account Number;Billing location, Patient name",";",BARSRTBY)

               End DoDot:1

 +21      ;

 +22      ; Select run to print

 +23       KILL DIR

 +24       SET DIR(0)="NO^1:"_BARCNT

 +25       DO ^DIR

 +26       IF '+Y

               Begin DoDot:1

 +27               WRITE !,"NONE SELECTED",!

 +28               DO EOP^BARUTL(0)

               End DoDot:1

               QUIT

 +29       SET BARRUNDT=BARRUN(+Y)

 +30      ; IHS/SD/PKD 10/12/10 KILL ARRAY

           KILL BARRUN

 +31       QUIT

 +32      ; ***

 +33      ;

RETAIN    ;

 +1        WRITE !,"DO YOU WISH TO RETAIN THE RUN TO PRINT AGAIN ?"

 +2        KILL DIR

 +3        SET DIR(0)="Y"

 +4        SET DIR("B")="N"

 +5        DO ^DIR

 +6        SET BARKILL=Y

 +7        QUIT

 +8       ; ***

 +9       ;

PRINT     ;EP

 +1       ;21 FEB 2012 P.OTT IHS/SD/OIT ADDED FOR QUEUED REPORTS

           DO GETHDR

 +2        SET BARTMP=$GET(^XTMP("BARPAS"_BARRUNDT,0,"DT"))

 +3       ;P.OTT

           SET BARSRTBY=$GET(^XTMP("BARPAS"_BARRUNDT,0,"SORTBY"),0)

 +4       ; Statement begin date

           SET BARDTB=$PIECE(BARTMP,U)

 +5       ; Statement end date

           SET BARDTE=$PIECE(BARTMP,U,2)

 +6        SET HL1="        BILLED    INSURANCE     PATIENT   ADJUSTED     INSURANCE    PATIENT"

 +7        SET HL2="        AMOUNT     PAYMENT      PAYMENT    AMOUNT     OUTSTANDING  AMOUNT DUE"

 +8        DO PRINT^BARMPAS2

 +9        QUIT

 +10      ;

PAZ       ; Add extra line feeds to force alignment

 +1       ; IHS/SD/PKD copied from PAZ^BARRUTL but for printers

 +2       ; BARRUTL quits if not terminal

 +3       ; IHS/SD/PKD 1.8*20 removed didn't work for network printers

           QUIT

 +4        IF '$DATA(IO("Q"))

               Begin DoDot:1

 +5                FOR

                       WRITE !

                       IF $Y>(IOSL+3)

                           QUIT

               End DoDot:1

 +6        QUIT

BARMPAS3.m