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
Q
;
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
Q
; ********************************************************************
;
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
Q
; ********************************************************************
;
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 !
Q
; ********************************************************************
;
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
Q
; ********************************************************************
;
EXIT ; EP
I AZKILL=0 K ^XTMP("AZLKPS",AZJB)
K AZJB,AZKILL
Q
;
;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
Q
; ***
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
Q
; ***
;
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
Q
; ***
;
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
Q
;
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)
Q
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
