ORPR09.m

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

FOOT(CNT) ;Footer

 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 ---ORPR09   2724     printed  Feb 18, 2025@23:59:16                                                                                                                                                                                                      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 

FOOT(CNT) ;Footer

 +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