ORPR09 ; slc/dcm - Getting Consults pre-formatted output ;12/21/98 12:16
;;3.0;ORDER ENTRY/RESULTS REPORTING;**11**;Dec 17, 1997
EN(Y,ORIFN,QUIET) ;Get consult report
I $G(ORTEST) D TEST Q
Q:'$L($T(GUI^GMRCP5))
N IEN,ARRAY,OREND,CNT,I
Q:'$D(^OR(100,+$G(ORIFN),0)) Q:'$G(^(4)) S IEN=+^(4)
S ARRAY="",CNT=1
D GUI^GMRCP5(.ARRAY,IEN)
S I=499999.9 F S I=$O(@ARRAY@(1,I)) Q:'I!(I>599999.9) S CNT=CNT+1
I $G(QUIET) K Y S (I,Y)=0 D Q
. S ORPICKUP=1,Y=$E(ARRAY,1,($L(ARRAY)-1))_",1)"
U IO
I '$D(ORIOSL) N ORIOSL S ORIOSL=$S($D(IOSL):IOSL,1:50)
I '$D(ORIOF) N ORIOF S ORIOF=$S($D(IOF):IOF,1:"!")
I $G(ORFIRST1)=0,$Y>ORIOSL W @ORIOF
D HEAD()
D TEXTOUT(ARRAY,299999.9,399999.9,1,$S($E(IOST)="C":2,1:CNT))
I $E(IOST)="C",$Y+CNT>ORIOSL D PGBRK^ORUHDR W @ORIOF
D FOOT(CNT)
I $E(IOST)="C" D PGBRK^ORUHDR
K @ARRAY
Q
TEXTOUT(OROOT,START,END,FFCHK,CNT) ;Non DIWP text function that Raps for ^TMP arays
I '$L($G(OROOT)) Q
N X,ORI
S ORI=$S($G(START):START,1:0),END=$S($G(END):END,1:99999999999)
F S ORI=$O(@OROOT@(1,ORI)) Q:'ORI!(ORI>END) S X=$S($L($G(@OROOT@(1,ORI))):@OROOT@(1,ORI),$L($G(@OROOT@(1,ORI,0))):@OROOT@(1,ORI,0),1:"") D:$G(FFCHK) FEED(CNT) Q:$G(OREND) W !,X
Q
TEST ;Test the output
W !,"This format does the entire consult report and cannot be customized"
W !,"There is no need for a separate Header and Footer formats."
W !,"..."
Q
TEST1 ;Test for Consult Body only
W !,"This format does the 'body' of the consult report"
W !,"Headers and Footers have to be added to the report"
W !,"format for a complete report."
Q
FEED(CNT) ;Roomcheck
Q:$G(ORTEST)
I $Y+CNT<ORIOSL Q
I $E(IOST)'="C" D FOOT(CNT)
I $E(IOST)="C" D PGBRK^ORUHDR W @ORIOF
I $E(IOST)'="C" D HEAD(1)
Q
HEAD(FF) ;Header
I $G(FF)!($E(IOST)="C") W @ORIOF
D TEXTOUT(ARRAY,99999.9,199999.9,,1)
Q
F Q:$Y+$G(CNT)>(ORIOSL-1) W !
D TEXTOUT(ARRAY,499999.9,599999.9,,1)
Q
EN1(Y,ORIFN,QUIET) ;Get consult report (Body only)
I $G(ORTEST) D TEST1 Q
Q:'$L($T(GUI^GMRCP5))
N IEN,ARRAY,OREND,CNT,I
Q:'$D(^OR(100,+$G(ORIFN),0)) Q:'$G(^(4)) S IEN=+^(4)
S ARRAY="",CNT=1
D GUI^GMRCP5(.ARRAY,IEN)
S I=99999.9 F S I=$O(@ARRAY@(1,I)) Q:'I!(I>199999.9) K @ARRAY@(1,I) ;Remove header
S I=499999.9 F S I=$O(@ARRAY@(1,I)) Q:'I!(I>599999.9) K @ARRAY@(1,I) ;Remove footer
I $G(QUIET) K Y S (I,Y)=0 D Q
. S ORPICKUP=1,Y=$E(ARRAY,1,($L(ARRAY)-1))_",1)"
U IO
I '$D(ORIOSL) N ORIOSL S ORIOSL=$S($D(IOSL):IOSL,1:50)
I '$D(ORIOF) N ORIOF S ORIOF=$S($D(IOF):IOF,1:"!")
I $G(ORFIRST1)=0,$Y>ORIOSL W @ORIOF
D TEXTOUT(ARRAY,299999.9,399999.9,1,$S($E(IOST)="C":2,1:CNT))
I $E(IOST)="C",$Y+CNT>ORIOSL D PGBRK^ORUHDR W @ORIOF
K @ARRAY
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORPR09 2724 printed Sep 23, 2025@20:09:03 Page 2
ORPR09 ; slc/dcm - Getting Consults pre-formatted output ;12/21/98 12:16
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11**;Dec 17, 1997
EN(Y,ORIFN,QUIET) ;Get consult report
+1 IF $GET(ORTEST)
DO TEST
QUIT
+2 if '$LENGTH($TEXT(GUI^GMRCP5))
QUIT
+3 NEW IEN,ARRAY,OREND,CNT,I
+4 if '$DATA(^OR(100,+$GET(ORIFN),0))
QUIT
if '$GET(^(4))
QUIT
SET IEN=+^(4)
+5 SET ARRAY=""
SET CNT=1
+6 DO GUI^GMRCP5(.ARRAY,IEN)
+7 SET I=499999.9
FOR
SET I=$ORDER(@ARRAY@(1,I))
if 'I!(I>599999.9)
QUIT
SET CNT=CNT+1
+8 IF $GET(QUIET)
KILL Y
SET (I,Y)=0
Begin DoDot:1
+9 SET ORPICKUP=1
SET Y=$EXTRACT(ARRAY,1,($LENGTH(ARRAY)-1))_",1)"
End DoDot:1
QUIT
+10 USE IO
+11 IF '$DATA(ORIOSL)
NEW ORIOSL
SET ORIOSL=$SELECT($DATA(IOSL):IOSL,1:50)
+12 IF '$DATA(ORIOF)
NEW ORIOF
SET ORIOF=$SELECT($DATA(IOF):IOF,1:"!")
+13 IF $GET(ORFIRST1)=0
IF $Y>ORIOSL
WRITE @ORIOF
+14 DO HEAD()
+15 DO TEXTOUT(ARRAY,299999.9,399999.9,1,$SELECT($EXTRACT(IOST)="C":2,1:CNT))
+16 IF $EXTRACT(IOST)="C"
IF $Y+CNT>ORIOSL
DO PGBRK^ORUHDR
WRITE @ORIOF
+17 DO FOOT(CNT)
+18 IF $EXTRACT(IOST)="C"
DO PGBRK^ORUHDR
+19 KILL @ARRAY
+20 QUIT
TEXTOUT(OROOT,START,END,FFCHK,CNT) ;Non DIWP text function that Raps for ^TMP arays
+1 IF '$LENGTH($GET(OROOT))
QUIT
+2 NEW X,ORI
+3 SET ORI=$SELECT($GET(START):START,1:0)
SET END=$SELECT($GET(END):END,1:99999999999)
+4 FOR
SET ORI=$ORDER(@OROOT@(1,ORI))
if 'ORI!(ORI>END)
QUIT
SET X=$SELECT($LENGTH($GET(@OROOT@(1,ORI))):@OROOT@(1,ORI),$LENGTH($GET(@OROOT@(1,ORI,0))):@OROOT@(1,ORI,0),1:"")
if $GET(FFCHK)
DO FEED(CNT)
if $GET(OREND)
QUIT
WRITE !,X
+5 QUIT
TEST ;Test the output
+1 WRITE !,"This format does the entire consult report and cannot be customized"
+2 WRITE !,"There is no need for a separate Header and Footer formats."
+3 WRITE !,"..."
+4 QUIT
TEST1 ;Test for Consult Body only
+1 WRITE !,"This format does the 'body' of the consult report"
+2 WRITE !,"Headers and Footers have to be added to the report"
+3 WRITE !,"format for a complete report."
+4 QUIT
FEED(CNT) ;Roomcheck
+1 if $GET(ORTEST)
QUIT
+2 IF $Y+CNT<ORIOSL
QUIT
+3 IF $EXTRACT(IOST)'="C"
DO FOOT(CNT)
+4 IF $EXTRACT(IOST)="C"
DO PGBRK^ORUHDR
WRITE @ORIOF
+5 IF $EXTRACT(IOST)'="C"
DO HEAD(1)
+6 QUIT
HEAD(FF) ;Header
+1 IF $GET(FF)!($EXTRACT(IOST)="C")
WRITE @ORIOF
+2 DO TEXTOUT(ARRAY,99999.9,199999.9,,1)
+3 QUIT
+1 FOR
if $Y+$GET(CNT)>(ORIOSL-1)
QUIT
WRITE !
+2 DO TEXTOUT(ARRAY,499999.9,599999.9,,1)
+3 QUIT
EN1(Y,ORIFN,QUIET) ;Get consult report (Body only)
+1 IF $GET(ORTEST)
DO TEST1
QUIT
+2 if '$LENGTH($TEXT(GUI^GMRCP5))
QUIT
+3 NEW IEN,ARRAY,OREND,CNT,I
+4 if '$DATA(^OR(100,+$GET(ORIFN),0))
QUIT
if '$GET(^(4))
QUIT
SET IEN=+^(4)
+5 SET ARRAY=""
SET CNT=1
+6 DO GUI^GMRCP5(.ARRAY,IEN)
+7 ;Remove header
SET I=99999.9
FOR
SET I=$ORDER(@ARRAY@(1,I))
if 'I!(I>199999.9)
QUIT
KILL @ARRAY@(1,I)
+8 ;Remove footer
SET I=499999.9
FOR
SET I=$ORDER(@ARRAY@(1,I))
if 'I!(I>599999.9)
QUIT
KILL @ARRAY@(1,I)
+9 IF $GET(QUIET)
KILL Y
SET (I,Y)=0
Begin DoDot:1
+10 SET ORPICKUP=1
SET Y=$EXTRACT(ARRAY,1,($LENGTH(ARRAY)-1))_",1)"
End DoDot:1
QUIT
+11 USE IO
+12 IF '$DATA(ORIOSL)
NEW ORIOSL
SET ORIOSL=$SELECT($DATA(IOSL):IOSL,1:50)
+13 IF '$DATA(ORIOF)
NEW ORIOF
SET ORIOF=$SELECT($DATA(IOF):IOF,1:"!")
+14 IF $GET(ORFIRST1)=0
IF $Y>ORIOSL
WRITE @ORIOF
+15 DO TEXTOUT(ARRAY,299999.9,399999.9,1,$SELECT($EXTRACT(IOST)="C":2,1:CNT))
+16 IF $EXTRACT(IOST)="C"
IF $Y+CNT>ORIOSL
DO PGBRK^ORUHDR
WRITE @ORIOF
+17 KILL @ARRAY
+18 QUIT
