BARLNRPT ; IHS/SD/LSL - Report Generator ;
;;1.8;IHS ACCOUNTS RECEIVABLE;;OCT 26, 2005
;;
EN ;EP ENTRY POINT
DIR1 K DIR
I '$D(BARDA) D SEL I '$G(BARDA) Q
;W !,"SPACE: ",$S,!
W !!,?10,"Report: ",$$VAL^XBDIQ1(90056.1,BARDA,.01)
W !,?10,"File: ",$$VAL^XBDIQ1(90056.1,BARDA,.02)
;S DIR(0)="S^R:RUN REPORT;E:EDIT REPORT;N:NEW REPORT;L:LIST ITEMS;X:EXIT" D ^DIR
S DIR(0)="S^R:RUN REPORT;E:EDIT REPORT;L:LIST ITEMS;X:EXIT" D ^DIR
I Y="R" D RUN G DIR1
I Y="N" D SEL G DIR1
I Y="E" D EDIT G DIR1
I Y="L" D ITEMLST(BARDA) G DIR1
I Y="X" K BARDA G DIR1
EXIT ;EP -
K BARDA
Q
;
SEL S DIC=90056.1,DIC(0)="AEQMLZ"
D ^DIC
Q:Y'>0
S BARDA=+Y
Q
EDIT S DDSFILE=90056.1,DR="[BAR REPORT GENERATOR]",DA=BARDA
D ^DDS
Q
R ;EP - RUN A REPORT
S DIC=90056.1,DIC(0)="AEQMLZ"
D ^DIC
Q:Y'>0
S BARDA=+Y
RUN ;EP - run report BARDA
S BARQUIT=0
D ENP^XBDIQ1(90056.1,BARDA,".01:999","BARPT(")
S XBSRCFL=$$VALI^XBDIQ1(90056.1,BARDA,.02)
S DIC=XBSRCFL
K DIR
K BARS,BARP
I $D(BARPT),+XBSRCFL
E W !,"Information Missing - Exiting",! H 2 Q
D SORT
I BARQUIT W !,"Sort Information Missing - Exiting",! H 2 Q
D PRINT
I BARQUIT W !,"Print Information Missing - Exiting",! H 2 Q
I XBSRCFL=90056.3 D Q:XBSRCFL'>0
. W !,"You have picked the A/R Items master file ",!
. ;K DIR S DIR(0)="P^90055.1" D ^DIR K DIR
. N DIC S DIC=90055.5,DIC(0)="AEQM" D ^DIC
. S XBSRCFL=+Y
;W ! ZW FLDS,FR,TO,BY K DIR S DIR(0)="E",DIR("A")="CR to continue" D ^DIR K DIR
K BARS,BARP,BARPT
S L=0 D EN1^DIP
K DIR S DIR(0)="E",DIR("A")="CR - CONTINUE" D ^DIR K DIR
Q
;
SORT ;EP reorder and build BY, FR, TO variables
;
S BY=$$VAL^XBDIQ1(90056.1,BARDA,.03)
I BY]"" S BY="["_BY_"]",FR="",TO="" Q
;
D ENPM^XBDIQ1(90056.12,"BARDA,0",".01:999","BARS(")
I '+$O(BARS(0)) S BARQUIT=1 Q
N DA,SEQ S DA=0
K BARSO,BARTS
F S DA=$O(BARS(DA)) Q:DA'>0 S SEQ=BARS(DA,.03) S BARSO(SEQ)=DA
S SEQ=0
K BARTS
F K=1:1 S SEQ=$O(BARSO(SEQ)) Q:SEQ'>0 S DA=BARSO(SEQ) M BARTS(K)=BARS(DA)
S BARS=K-1,BY=""
F BARS=1:1:BARS S $P(BY,",",BARS)=BARTS(BARS,9.05)_BARTS(BARS,.02)
S FR=""
F BARS=1:1:BARS S BARX=BARTS(BARS,.04) S:BARX="Q" BARX="?" S $P(FR,",",BARS)=BARX
S TO=""
F BARS=1:1:BARS S BARX=BARTS(BARS,.05) S:BARX="Q" BARX="?" S $P(TO,",",BARS)=BARX
K BARTS,BARSO
Q
PRINT ;EP - reorder and build FLDS variable
;
S FLDS=$$VAL^XBDIQ1(90056.1,BARDA,.04)
I FLDS]"" S FLDS="["_FLDS_"]" Q
;
D ENPM^XBDIQ1(90056.13,"BARDA,0",".01:999","BARP(")
I '+$O(BARP(0)) S BARQUIT=1 Q
S DA=0
K BARPO,BARTP
F S DA=$O(BARP(DA)) Q:DA'>0 S SEQ=BARP(DA,.03) S BARPO(SEQ)=DA
S SEQ=0
F K=1:1 S SEQ=$O(BARPO(SEQ)) Q:SEQ'>0 S DA=BARPO(SEQ) M BARTP(K)=BARP(DA)
S BARP=K-1
F BARP=1:1:BARP K BARX S $P(BARX,",",BARTP(BARP,9.06))="" D
. ;I $L(BARTP(BARP,.04)) S BARTP(BARP,9.05)=BARTP(BARP,.04)_"(#"_BARTP(BARP,9.05)_")"
.S BARFLD(BARP)=BARTP(BARP,9.05)_BARTP(BARP,.02)
.S X=$L(BARFLD(BARP),",") F I=1:1:X-1 S BARFLD(BARP)=BARFLD(BARP)_","
S SEP=","
S FLDS=BARFLD(1)
;F BARP=2:1:BARP S FLDS=FLDS_SEP_BARFLD(BARP)
;S FLDS=FLDS_SEP
F I=2:1:BARP S FLDS(I-1)=BARFLD(I)
K BARPO,BARTP,BARFLD
Q
ITEMS ;EP - LIST SELECTABLE ITEMS
K DIC,DA,DR
S DIC=90055.5,DIC(0)="AEQM" D ^DIC
Q:Y'>0
S XBSRCFL=+Y
D ITEMLST
G ITEMS
Q
ITEMLST(BARDA) ;EP - list items
S XBSRCFL=$$VALI^XBDIQ1(90056.1,BARDA,.02)
D LIST(XBSRCFL)
Q
LIST(XBSRCFL) ;EP Print fields
S DIC=90056.3
S FLDS=".01;L30;""Field"""
S FLDS(1)=".05;L12;""FM Path"""
S FLDS(2)="1.04;L25;""Data Path"""
S FLDS(3)=".04;L2;""AT"""
S FLDS(4)=".055;L0;"""
S FR=",,",BY=".055,.05,.01"
S L=0
D EN1^DIP
K DIR S DIR(0)="E",DIR("A")="CR CONTINUE" D ^DIR
END Q
PRT ;EP
;
; GET DEVICE (QUEUEING ALLOWED)
S Y=$$DIR^XBDIR("S^P:PRINT Output;B:BROWSE Output on Screen","Do you wish to ","P","","","",1)
K DA
Q:$D(DIRUT)
I Y="B" S XBFLD("BROWSE")=1,BARIOSL=IOSL,IOSL=600 D VIEWD^XBLM("EN1^DIP"),FULL^VALM1 W $$EN^BARVDF("IOF") D Q
.D CLEAR^VALM1 ;clears out all list man stuff
.KILL XQORNEST,VALMKEY,VALM,VALMAR,VALMBCK,VALMBG,VALMCAP,VALMCNT,VALMOFF,VALMCON,VALMDN,VALMEVL,VALMIOXY,VALMLFT,VALMLST,VALMMENU,VALMSGR,VALMUP,VALMY,XQORS,XQORSPEW,VALMCOFF
DEVE .S IOSL=BARIOSL K BARIOSL Q
D EN1^DIP
;S XBRP="LOOP^BAREDP07",XBNS="BAR;IMPDA",XBRX="EXIT^BAREDP07"
;D ^XBDBQUE
K DIR S DIR(0)="E",DIR("A")="<CR> - Continue" D ^DIR K DIR
;G EN
ENDJOB Q
LOOP ;EP CLAIMS
BARLNRPT ; IHS/SD/LSL - Report Generator ;
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;;OCT 26, 2005
+2 ;;
EN ;EP ENTRY POINT
DIR1 KILL DIR
+1 IF '$DATA(BARDA)
DO SEL
IF '$GET(BARDA)
QUIT
+2 ;W !,"SPACE: ",$S,!
+3 WRITE !!,?10,"Report: ",$$VAL^XBDIQ1(90056.1,BARDA,.01)
+4 WRITE !,?10,"File: ",$$VAL^XBDIQ1(90056.1,BARDA,.02)
+5 ;S DIR(0)="S^R:RUN REPORT;E:EDIT REPORT;N:NEW REPORT;L:LIST ITEMS;X:EXIT" D ^DIR
+6 SET DIR(0)="S^R:RUN REPORT;E:EDIT REPORT;L:LIST ITEMS;X:EXIT"
DO ^DIR
+7 IF Y="R"
DO RUN
GOTO DIR1
+8 IF Y="N"
DO SEL
GOTO DIR1
+9 IF Y="E"
DO EDIT
GOTO DIR1
+10 IF Y="L"
DO ITEMLST(BARDA)
GOTO DIR1
+11 IF Y="X"
KILL BARDA
GOTO DIR1
EXIT ;EP -
+1 KILL BARDA
+2 QUIT
+3 ;
SEL SET DIC=90056.1
SET DIC(0)="AEQMLZ"
+1 DO ^DIC
+2 IF Y'>0
QUIT
+3 SET BARDA=+Y
+4 QUIT
EDIT SET DDSFILE=90056.1
SET DR="[BAR REPORT GENERATOR]"
SET DA=BARDA
+1 DO ^DDS
+2 QUIT
R ;EP - RUN A REPORT
+1 SET DIC=90056.1
SET DIC(0)="AEQMLZ"
+2 DO ^DIC
+3 IF Y'>0
QUIT
+4 SET BARDA=+Y
RUN ;EP - run report BARDA
+1 SET BARQUIT=0
+2 DO ENP^XBDIQ1(90056.1,BARDA,".01:999","BARPT(")
+3 SET XBSRCFL=$$VALI^XBDIQ1(90056.1,BARDA,.02)
+4 SET DIC=XBSRCFL
+5 KILL DIR
+6 KILL BARS,BARP
+7 IF $DATA(BARPT)
IF +XBSRCFL
+8 IF '$TEST
WRITE !,"Information Missing - Exiting",!
HANG 2
QUIT
+9 DO SORT
+10 IF BARQUIT
WRITE !,"Sort Information Missing - Exiting",!
HANG 2
QUIT
+11 DO PRINT
+12 IF BARQUIT
WRITE !,"Print Information Missing - Exiting",!
HANG 2
QUIT
+13 IF XBSRCFL=90056.3
Begin DoDot:1
+14 WRITE !,"You have picked the A/R Items master file ",!
+15 ;K DIR S DIR(0)="P^90055.1" D ^DIR K DIR
+16 NEW DIC
SET DIC=90055.5
SET DIC(0)="AEQM"
DO ^DIC
+17 SET XBSRCFL=+Y
End DoDot:1
IF XBSRCFL'>0
QUIT
+18 ;W ! ZW FLDS,FR,TO,BY K DIR S DIR(0)="E",DIR("A")="CR to continue" D ^DIR K DIR
+19 KILL BARS,BARP,BARPT
+20 SET L=0
DO EN1^DIP
+21 KILL DIR
SET DIR(0)="E"
SET DIR("A")="CR - CONTINUE"
DO ^DIR
KILL DIR
+22 QUIT
+23 ;
SORT ;EP reorder and build BY, FR, TO variables
+1 ;
+2 SET BY=$$VAL^XBDIQ1(90056.1,BARDA,.03)
+3 IF BY]""
SET BY="["_BY_"]"
SET FR=""
SET TO=""
QUIT
+4 ;
+5 DO ENPM^XBDIQ1(90056.12,"BARDA,0",".01:999","BARS(")
+6 IF '+$ORDER(BARS(0))
SET BARQUIT=1
QUIT
+7 NEW DA,SEQ
SET DA=0
+8 KILL BARSO,BARTS
+9 FOR
SET DA=$ORDER(BARS(DA))
IF DA'>0
QUIT
SET SEQ=BARS(DA,.03)
SET BARSO(SEQ)=DA
+10 SET SEQ=0
+11 KILL BARTS
+12 FOR K=1:1
SET SEQ=$ORDER(BARSO(SEQ))
IF SEQ'>0
QUIT
SET DA=BARSO(SEQ)
MERGE BARTS(K)=BARS(DA)
+13 SET BARS=K-1
SET BY=""
+14 FOR BARS=1:1:BARS
SET $PIECE(BY,",",BARS)=BARTS(BARS,9.05)_BARTS(BARS,.02)
+15 SET FR=""
+16 FOR BARS=1:1:BARS
SET BARX=BARTS(BARS,.04)
IF BARX="Q"
SET BARX="?"
SET $PIECE(FR,",",BARS)=BARX
+17 SET TO=""
+18 FOR BARS=1:1:BARS
SET BARX=BARTS(BARS,.05)
IF BARX="Q"
SET BARX="?"
SET $PIECE(TO,",",BARS)=BARX
+19 KILL BARTS,BARSO
+20 QUIT
PRINT ;EP - reorder and build FLDS variable
+1 ;
+2 SET FLDS=$$VAL^XBDIQ1(90056.1,BARDA,.04)
+3 IF FLDS]""
SET FLDS="["_FLDS_"]"
QUIT
+4 ;
+5 DO ENPM^XBDIQ1(90056.13,"BARDA,0",".01:999","BARP(")
+6 IF '+$ORDER(BARP(0))
SET BARQUIT=1
QUIT
+7 SET DA=0
+8 KILL BARPO,BARTP
+9 FOR
SET DA=$ORDER(BARP(DA))
IF DA'>0
QUIT
SET SEQ=BARP(DA,.03)
SET BARPO(SEQ)=DA
+10 SET SEQ=0
+11 FOR K=1:1
SET SEQ=$ORDER(BARPO(SEQ))
IF SEQ'>0
QUIT
SET DA=BARPO(SEQ)
MERGE BARTP(K)=BARP(DA)
+12 SET BARP=K-1
+13 FOR BARP=1:1:BARP
KILL BARX
SET $PIECE(BARX,",",BARTP(BARP,9.06))=""
Begin DoDot:1
+14 ;I $L(BARTP(BARP,.04)) S BARTP(BARP,9.05)=BARTP(BARP,.04)_"(#"_BARTP(BARP,9.05)_")"
+15 SET BARFLD(BARP)=BARTP(BARP,9.05)_BARTP(BARP,.02)
+16 SET X=$LENGTH(BARFLD(BARP),",")
FOR I=1:1:X-1
SET BARFLD(BARP)=BARFLD(BARP)_","
End DoDot:1
+17 SET SEP=","
+18 SET FLDS=BARFLD(1)
+19 ;F BARP=2:1:BARP S FLDS=FLDS_SEP_BARFLD(BARP)
+20 ;S FLDS=FLDS_SEP
+21 FOR I=2:1:BARP
SET FLDS(I-1)=BARFLD(I)
+22 KILL BARPO,BARTP,BARFLD
+23 QUIT
ITEMS ;EP - LIST SELECTABLE ITEMS
+1 KILL DIC,DA,DR
+2 SET DIC=90055.5
SET DIC(0)="AEQM"
DO ^DIC
+3 IF Y'>0
QUIT
+4 SET XBSRCFL=+Y
+5 DO ITEMLST
+6 GOTO ITEMS
+7 QUIT
ITEMLST(BARDA) ;EP - list items
+1 SET XBSRCFL=$$VALI^XBDIQ1(90056.1,BARDA,.02)
+2 DO LIST(XBSRCFL)
+3 QUIT
LIST(XBSRCFL) ;EP Print fields
+1 SET DIC=90056.3
+2 SET FLDS=".01;L30;""Field"""
+3 SET FLDS(1)=".05;L12;""FM Path"""
+4 SET FLDS(2)="1.04;L25;""Data Path"""
+5 SET FLDS(3)=".04;L2;""AT"""
+6 SET FLDS(4)=".055;L0;"""
+7 SET FR=",,"
SET BY=".055,.05,.01"
+8 SET L=0
+9 DO EN1^DIP
+10 KILL DIR
SET DIR(0)="E"
SET DIR("A")="CR CONTINUE"
DO ^DIR
END QUIT
PRT ;EP
+1 ;
+2 ; GET DEVICE (QUEUEING ALLOWED)
+3 SET Y=$$DIR^XBDIR("S^P:PRINT Output;B:BROWSE Output on Screen","Do you wish to ","P","","","",1)
+4 KILL DA
+5 IF $DATA(DIRUT)
QUIT
+6 IF Y="B"
SET XBFLD("BROWSE")=1
SET BARIOSL=IOSL
SET IOSL=600
DO VIEWD^XBLM("EN1^DIP")
DO FULL^VALM1
WRITE $$EN^BARVDF("IOF")
Begin DoDot:1
+7 ;clears out all list man stuff
DO CLEAR^VALM1
+8 KILL XQORNEST,VALMKEY,VALM,VALMAR,VALMBCK,VALMBG,VALMCAP,VALMCNT,VALMOFF,VALMCON,VALMDN,VALMEVL,VALMIOXY,VALMLFT,VALMLST,VALMMENU,VALMSGR,VALMUP,VALMY,XQORS,XQORSPEW,VALMCOFF
DEVE SET IOSL=BARIOSL
KILL BARIOSL
QUIT
End DoDot:1
QUIT
+1 DO EN1^DIP
+2 ;S XBRP="LOOP^BAREDP07",XBNS="BAR;IMPDA",XBRX="EXIT^BAREDP07"
+3 ;D ^XBDBQUE
+4 KILL DIR
SET DIR(0)="E"
SET DIR("A")="<CR> - Continue"
DO ^DIR
KILL DIR
+5 ;G EN
ENDJOB QUIT
LOOP ;EP CLAIMS
