Routine: ORPRS04

ORPRS04 ;slc/dcm - Print Order summaries (SHRIVELED) ;09/30/15  11:55

 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,69,92,121,350**;Dec 17, 1997;Build 77

EN ;Print orders

 I $$S^%ZTLOAD S (ZTSTOP,DIROUT,OREND)=1 W !!,"TASKED Report stopped by WHILE RUNNING." Q

 N DIRUT,DUOUT,ORCONT,ORLINE,ORLSTO,ORDAD,ORLST,OREND,YENKO,SHELBY

 K ORSPG

 S YENKO=$$GET^XPAR("ALL","OR PRINT NO ORDERS ON SUM",1,"I"),SHELBY=$O(^TMP("ORR",$J,ORLIST,0))

 ;YENKO=0 or "", if you don't want to print a page when no orders are present

 ;      1 to print the page with "NO ORDERS" on it.

 I 'YENKO,'SHELBY Q

 S $P(ORLINE,"-",IOM+1)="",ORBOT=$S(IOSL<254:IOSL,1:254),Y=+ORVP,ORDAD="",OREND=0

 D END^ORUDPA

 S ORREQ("O")=""

 I $Y+11>IOSL,$E(IOST)="P" W @IOF

 I '$G(ORSPG) S ORSPG=1 D

 . I $E(IOST)="C" D CTOP^ORPRS05(ORSPG,$G(ORSEND),$G(ORSPG("EOP")),ORTIT,ORSHORT,ORL(0),ORL(1),ORWARD,ORPNM,ORSSN,ORDOB,ORAGE,$G(ORPD)) Q

 . D PTOP^ORPRS05(ORSPG,ORTIT,ORSHORT,ORSSTRT,ORSSTOP)

 D PTHDR

 I '$O(^TMP("ORR",$J,ORLIST,0)) W !!?3,"No orders.",!,ORLINE D  Q

 . S ORSPG("EOP")=1

 . I $E(IOST)="C" D  Q

 .. K Y F  Q:$G(Y)["^"!($G(Y)=-1)  K DIR S DIR(0)="FO^1;2",DIR("A")="Press RETURN to continue or '^' to exit" D ^DIR S:Y="" Y=-1 K DIR Q:Y<0  D

 ... I Y'["^" W $C(7),!!,"Enter '^' to stop listing for current patient"

 . D PBOT^ORPRS05(1,ORBOT,ORPNM,ORSSN,ORDOB,ORAGE,$G(ORPD),ORL(0),ORL(1),$G(ORSHORT))

 . I '$G(ORSEND) Q

 . W !!!!!?(IOM-44)\2,"*****    E N D    O F    R E P O R T    ****",!

 . K ORSEND,ORSPG,ORCONT

 S ORCONT=1,ORLSTO=0,ORLST=0

 F  S ORLST=$O(^TMP("ORR",$J,ORLIST,ORLST)) Q:'ORLST!$D(DUOUT)  D PRT Q:OREND

 Q:OREND!$D(DUOUT)!$D(DTOUT)!$G(ORSPG("LAST"))

 S ORLSTO=1

 D PGCHK()

PRT ;Print order line

 N ORXPND,OACTION,ORIFN,ORASTS,ORSTS,ORTX,ORODT,ORSTOP,ORUSER,ORSTRT,ORMD,OREL,ORFLAG,ORNAT

 S ORIFN=+^TMP("ORR",$J,ORLIST,ORLST),OACTION=$P(^(ORLST),";",2)

 I ORSHORT,$G(ORSPG("EOP")) S ORREQ("O")="" D PTOP^ORPRS05(ORSPG,ORTIT,ORSHORT,ORSSTRT,ORSSTOP),PTHDR S ORSPG("EOP")=0

 I 'ORSHORT,$G(ORSPG("EOP")) D:$E(IOST)="C" CTOP^ORPRS05(ORSPG,$G(ORSEND),$G(ORSPG("EOP")),ORTIT,ORSHORT,ORL(0),ORL(1),ORWARD,ORPNM,ORSSN,ORDOB,ORAGE,$G(ORPD)) S ORSPG("EOP")=ORSPG

 I $G(ORSPG(0))'=ORSPG S (ORREQ("O"),ORREQ("TIT",0))="",ORSPG(0)=ORSPG

 Q:'$D(^OR(100,ORIFN,0))  S X=^(0),X3=$S($D(^(3)):^(3),1:""),ORDAD=$O(^(2,0))

 S ORREQ=$P(X,"^",4),ORODT=$P(X,"^",7),ORSTOP=$P(X,"^",9),ORUSER=$P(X,"^",6),ORSTS=$P(X3,"^",3),ORSTRT=$P(X,"^",8),ORMD=$P(X3,"^",13),OREL=$S(ORSTS=11:1,1:"")

 I $D(^OR(100,ORIFN,8,OACTION,0)) S X=^(0),ORODT=+X,ORREQ=$P(X,"^",3),ORMD=$P(X,"^",4),ORNAT=$P(X,"^",12),ORUSER=$P(X,"^",13),ORASTS=$P(X,"^",15),OREL=$S(ORASTS=11:1,1:"")

 S ORREQ=$S(ORREQ:$S($D(^VA(200,ORREQ,0)):$P(^(0),"^"),1:"UNKNOWN"),1:"UNKNOWN"),ORREQ("TIT")=" " I ORREQ'="UNKNOWN" S X=$P(^(0),U,9),ORREQ("TIT")=$P($G(^DIC(3.1,+X,0)),U) I ORREQ("TIT")']"" S ORREQ("TIT")=" "

 D TEXT^ORQ12(.ORTX,$S($G(OACTION):ORIFN_";"_OACTION,1:ORIFN),40)

 S X=$P(ORREQ,",",2),ORREQ=$E($P(ORREQ,","),1,8)_","_$S($E(X)=" ":$E(X,$F(X,"")),1:$E(X))

 S:ORREQ'=ORREQ("O") ORREQ("O")=ORREQ,ORREQ("F")=1,ORREQ("TIT",0)=""

 S:'ORREQ("F")&(ORREQ=ORREQ("O")) ORREQ="    """

 S ORREQ("F")=0

 S:ORREQ("TIT")'=$G(ORREQ("TIT",0)) ORREQ("TIT",0)=ORREQ("TIT"),ORREQ("F")=1

 S:'ORREQ("F")&(ORREQ("TIT")=ORREQ("TIT",0)) ORREQ("TIT")="    """

 S ORREQ("F")=0

STS ;

 S ORSTS=$S($G(ORASTS)!(ORSTS):" "_$P(^ORD(100.01,$S($G(ORASTS):ORASTS,1:ORSTS),.1),"^"),1:" ")

 D:'$D(ORTERM(5)) TERM^ORPRS01(IOST)

 S ORFLAG=$$FLAG^ORPRS03(ORIFN,ORTERM(5))

 S ORXPND=$O(ORTX(""),-1)

 D PGCHK(ORXPND+1)

 Q:OREND

 W !!

 S X=$P(ORTERM(7),"^")

 S:OREL X=$$INV^ORU

 W:$L(ORODT) $E(ORODT,4,5)_"/"_$E(ORODT,6,7)_"/"_$E(ORODT,2,3)

 W ?8,ORSTS,?12,$S(ORDAD:"+",1:" ")

 W:$O(ORTX(0)) ORTX($O(ORTX(0)))

 W ?54,ORREQ W:$L(ORSTRT) ?65,$E(ORSTRT,4,5)_"/"_$E(ORSTRT,6,7)_"/"_$E(ORSTRT,2,3)

 W:$L(ORSTOP) ?75,$E(ORSTOP,4,5)_"/"_$E(ORSTOP,6,7)

 W !?3,$$MTIM(ORODT),?13

 S X=$O(ORTX(0))

 I X W:$O(ORTX(X)) ORTX($O(ORTX(X)))

 W ?54,$E(ORREQ("TIT"),1,10),?68,$$MTIM(ORSTRT),?75,$$MTIM(ORSTOP)

 S X=0 F I=1:1 S X=$O(ORTX(X)) Q:'X  I I>2 W !?13,ORTX(X) D:($Y>(IOSL-5)) PGCHK(ORXPND-I) Q:OREND

 Q:OREND

W !

 I $$GET^XPAR("ALL","ORPF INITIALS ON SUMMARY",1,"I"),ORUSER W ?1,$P($G(^VA(200,ORUSER,0)),"^",2)

 I $D(^OR(100,ORIFN,8,OACTION,0)) S X=^(0) D

 . N NATURE,SIGSTS,NURSE,REVIEW

 . S SIGSTS=$P(X,"^",4),NATURE=$P(X,"^",12),NURSE=$P(X,"^",8),REVIEW=$P(X,"^",18)

 . I $L(SIGSTS) S SIGSTS=$$SET(100.008,4,SIGSTS)

 . I NATURE S NATURE=$P($G(^ORD(100.02,NATURE,0)),"^")

 . I NURSE S NURSE=$P($G(^VA(200,NURSE,0)),"^",2)

 . I REVIEW S REVIEW=$P($G(^VA(200,REVIEW,0)),"^",2)

 . W:$L(NURSE) ?9,"Nrs:"_NURSE

 . W:$L(REVIEW) ?19,"Chrt:"_REVIEW

 . W:$L(NATURE) ?30,"Typ:"_$E(NATURE,1,18)

 . W:$L(SIGSTS) ?54,"Sgn:"_$E(SIGSTS,1,25)

 I $D(^OR(100,ORIFN,5,0)) S J=0 F  S J=$O(^OR(100,ORIFN,5,J)) Q:'J  W !?13,^(J,0)

 I ORDAD D  Q:OREND

 . N I,ORSEQ

 . S I=0,ORSEQ=0,ORTIT(0)=ORTIT

 . D KIDS(ORIFN)

 . S ORTIT=ORTIT(0)

 I OREL W !?66,"*UNRELEASED*" S X=$P(ORTERM(7),U,3),X=$$INV^ORU

 S ORSPG("LAST")='$O(^TMP("ORR",$J,ORLIST,ORLST)),ORCONT='ORSPG("LAST")

 D PGCHK()

PGCHK(CNT) ;

 N DIR,X,I

 S:'$D(CNT) CNT=0

 I $G(ORSPG("LAST")) W !!,?32,"* END OF ORDERS *" W:'$G(ORSHORT) !,ORLINE D

 . I $E(IOST)="P" D PBOT^ORPRS05(ORSPG,IOSL,ORPNM,ORSSN,ORDOB,ORAGE,$G(ORPD),ORL(0),ORL(1),$G(ORSHORT)) I '$G(ORSHORT)!($Y+15>IOSL) W @IOF

 . I $E(IOST)="C" W ! S DIR(0)="FO^1;2",DIR("A")="Press RETURN to continue, '^' to exit" D ^DIR I $D(DUOUT) S OREND=1 Q

 I $G(ORSEND),$G(ORLSTO) D  K ORSEND,ORCONT Q

 . W !?(IOM-44)\2,"*****    E N D    O F    R E P O R T    ****",!

 . I $E(IOST)="C" W ! S DIR(0)="FO^1;2",DIR("A")="Press RETURN to continue, '^' to exit" D ^DIR I $D(DUOUT) S OREND=1 Q

 I $G(ORSPG("LAST")) Q

 I $E(IOST)="C" D  Q

 . I ((IOSL-$Y)>(4+CNT))!(CNT+4>(IOSL-3)) Q

 . S ORSPG=$G(ORSPG)+1

 . W !

 . S DIR(0)="FO^1;2",DIR("A")="Press RETURN to continue or '^' to exit"

 . D ^DIR

 . I $D(DUOUT) K ORSEND,ORCONT S OREND=1 Q

 . D CTOP^ORPRS05(ORSPG,$G(ORSEND),$G(ORSPG("EOP")),ORTIT,ORSHORT,ORL(0),ORL(1),ORWARD,ORPNM,ORSSN,ORDOB,ORAGE,$G(ORPD))

 . S ORSPG=0

 . I $G(ORCONT) D PTHDR

 I ((IOSL-$Y)>(6+CNT))!(CNT+6>(IOSL-5)) Q

 D PBOT^ORPRS05(ORSPG,IOSL,ORPNM,ORSSN,ORDOB,ORAGE,$G(ORPD),ORL(0),ORL(1),$G(ORSHORT))

 S ORSPG=ORSPG+1

 W @IOF

 D PTOP^ORPRS05(ORSPG,ORTIT,ORSHORT,ORSSTRT,ORSSTOP)

 I $G(ORCONT) D PTHDR

PTHDR ;

 W !,ORPNM_"   "_$G(ORSSN)_" "_$S($G(ORCONT):"(cont.)",1:"")_" "

 S X=$P(ORWARD,"^",2)_"  "_ORL(1)

 W ?(80-$L(X))\2,X

KIDS(ORIFN,LENGTH) ;Print child orders

 N ORCHLD,OROIFN

 S OROIFN=ORIFN,ORCHLD=0

 F I=0:0 S ORCHLD=$O(^OR(100,OROIFN,2,ORCHLD)) Q:ORCHLD<1  D PGCHK() Q:OREND  S ORIFN=ORCHLD D ONE^ORPRS03(ORCHLD,"         ",$G(LENGTH))

MTIM(X) ;Format time from Fileman date in X

 I '$G(X) Q ""

 S X=$P(X,".",2)

 Q:'$L(X) ""

 S X=$E(X,1,2)_$E("00",0,2-$L($E(X,1,2)))_":"_$E(X,3,4)_$E("00",0,2-$L($E(X,3,4)))

Q X

SET(FILE,FIELD,RESULT) ;Interpret set of codes

 S X=$P(^DD(FILE,FIELD,0),"^",3),X=$P($P(";"_X,";"_RESULT_":",2),";")

Q X

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORPRS04   7073     printed  Feb 18, 2025@23:59:24                                                                                                                                                                                                     Page 2

ORPRS04   ;slc/dcm - Print Order summaries (SHRIVELED) ;09/30/15  11:55

 +1       ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,69,92,121,350**;Dec 17, 1997;Build 77

EN        ;Print orders

 +1        IF $$S^%ZTLOAD

               SET (ZTSTOP,DIROUT,OREND)=1

               WRITE !!,"TASKED Report stopped by WHILE RUNNING."

               QUIT

 +2        NEW DIRUT,DUOUT,ORCONT,ORLINE,ORLSTO,ORDAD,ORLST,OREND,YENKO,SHELBY

 +3        KILL ORSPG

 +4        SET YENKO=$$GET^XPAR("ALL","OR PRINT NO ORDERS ON SUM",1,"I")

           SET SHELBY=$ORDER(^TMP("ORR",$JOB,ORLIST,0))

 +5       ;YENKO=0 or "", if you don't want to print a page when no orders are present

 +6       ;      1 to print the page with "NO ORDERS" on it.

 +7        IF 'YENKO

               IF 'SHELBY

                   QUIT

 +8        SET $PIECE(ORLINE,"-",IOM+1)=""

           SET ORBOT=$SELECT(IOSL<254:IOSL,1:254)

           SET Y=+ORVP

           SET ORDAD=""

           SET OREND=0

 +9        DO END^ORUDPA

 +10       SET ORREQ("O")=""

 +11       IF $Y+11>IOSL

               IF $EXTRACT(IOST)="P"

                   WRITE @IOF

 +12       IF '$GET(ORSPG)

               SET ORSPG=1

               Begin DoDot:1

 +13               IF $EXTRACT(IOST)="C"

                       DO CTOP^ORPRS05(ORSPG,$GET(ORSEND),$GET(ORSPG("EOP")),ORTIT,ORSHORT,ORL(0),ORL(1),ORWARD,ORPNM,ORSSN,ORDOB,ORAGE,$GET(ORPD))

                       QUIT

 +14               DO PTOP^ORPRS05(ORSPG,ORTIT,ORSHORT,ORSSTRT,ORSSTOP)

               End DoDot:1

 +15       DO PTHDR

 +16       IF '$ORDER(^TMP("ORR",$JOB,ORLIST,0))

               WRITE !!?3,"No orders.",!,ORLINE

               Begin DoDot:1

 +17               SET ORSPG("EOP")=1

 +18               IF $EXTRACT(IOST)="C"

                       Begin DoDot:2

 +19                       KILL Y

FOR

                               if $GET(Y)["^"!($GET(Y)=-1)

                                   QUIT

                               KILL DIR

                               SET DIR(0)="FO^1;2"

                               SET DIR("A")="Press RETURN to continue or '^' to exit"

                               DO ^DIR

                               if Y=""

                                   SET Y=-1

                               KILL DIR

                               if Y<0

                                   QUIT

                               Begin DoDot:3

 +20                               IF Y'["^"

                                       WRITE $CHAR(7),!!,"Enter '^' to stop listing for current patient"

                               End DoDot:3

                       End DoDot:2

                       QUIT

 +21               DO PBOT^ORPRS05(1,ORBOT,ORPNM,ORSSN,ORDOB,ORAGE,$GET(ORPD),ORL(0),ORL(1),$GET(ORSHORT))

 +22               IF '$GET(ORSEND)

                       QUIT

 +23               WRITE !!!!!?(IOM-44)\2,"*****    E N D    O F    R E P O R T    ****",!

 +24               KILL ORSEND,ORSPG,ORCONT

               End DoDot:1

               QUIT

 +25       SET ORCONT=1

           SET ORLSTO=0

           SET ORLST=0

 +26       FOR

               SET ORLST=$ORDER(^TMP("ORR",$JOB,ORLIST,ORLST))

               if 'ORLST!$DATA(DUOUT)

                   QUIT

               DO PRT

               if OREND

                   QUIT

 +27       if OREND!$DATA(DUOUT)!$DATA(DTOUT)!$GET(ORSPG("LAST"))

               QUIT

 +28       SET ORLSTO=1

 +29       DO PGCHK()

 +30       QUIT

PRT       ;Print order line

 +1        NEW ORXPND,OACTION,ORIFN,ORASTS,ORSTS,ORTX,ORODT,ORSTOP,ORUSER,ORSTRT,ORMD,OREL,ORFLAG,ORNAT

 +2        SET ORIFN=+^TMP("ORR",$JOB,ORLIST,ORLST)

           SET OACTION=$PIECE(^(ORLST),";",2)

 +3        IF ORSHORT

               IF $GET(ORSPG("EOP"))

                   SET ORREQ("O")=""

                   DO PTOP^ORPRS05(ORSPG,ORTIT,ORSHORT,ORSSTRT,ORSSTOP)

                   DO PTHDR

                   SET ORSPG("EOP")=0

 +4        IF 'ORSHORT

               IF $GET(ORSPG("EOP"))

                   if $EXTRACT(IOST)="C"

                       DO CTOP^ORPRS05(ORSPG,$GET(ORSEND),$GET(ORSPG("EOP")),ORTIT,ORSHORT,ORL(0),ORL(1),ORWARD,ORPNM,ORSSN,ORDOB,ORAGE,$GET(ORPD))

                   SET ORSPG("EOP")=ORSPG

 +5        IF $GET(ORSPG(0))'=ORSPG

               SET (ORREQ("O"),ORREQ("TIT",0))=""

               SET ORSPG(0)=ORSPG

 +6        if '$DATA(^OR(100,ORIFN,0))

               QUIT

           SET X=^(0)

           SET X3=$SELECT($DATA(^(3)):^(3),1:"")

           SET ORDAD=$ORDER(^(2,0))

 +7        SET ORREQ=$PIECE(X,"^",4)

           SET ORODT=$PIECE(X,"^",7)

           SET ORSTOP=$PIECE(X,"^",9)

           SET ORUSER=$PIECE(X,"^",6)

           SET ORSTS=$PIECE(X3,"^",3)

           SET ORSTRT=$PIECE(X,"^",8)

           SET ORMD=$PIECE(X3,"^",13)

           SET OREL=$SELECT(ORSTS=11:1,1:"")

 +8        IF $DATA(^OR(100,ORIFN,8,OACTION,0))

               SET X=^(0)

               SET ORODT=+X

               SET ORREQ=$PIECE(X,"^",3)

               SET ORMD=$PIECE(X,"^",4)

               SET ORNAT=$PIECE(X,"^",12)

               SET ORUSER=$PIECE(X,"^",13)

               SET ORASTS=$PIECE(X,"^",15)

               SET OREL=$SELECT(ORASTS=11:1,1:"")

 +9        SET ORREQ=$SELECT(ORREQ:$SELECT($DATA(^VA(200,ORREQ,0)):$PIECE(^(0),"^"),1:"UNKNOWN"),1:"UNKNOWN")

           SET ORREQ("TIT")=" "

           IF ORREQ'="UNKNOWN"

               SET X=$PIECE(^(0),U,9)

               SET ORREQ("TIT")=$PIECE($GET(^DIC(3.1,+X,0)),U)

               IF ORREQ("TIT")']""

                   SET ORREQ("TIT")=" "

 +10       DO TEXT^ORQ12(.ORTX,$SELECT($GET(OACTION):ORIFN_";"_OACTION,1:ORIFN),40)

 +11       SET X=$PIECE(ORREQ,",",2)

           SET ORREQ=$EXTRACT($PIECE(ORREQ,","),1,8)_","_$SELECT($EXTRACT(X)=" ":$EXTRACT(X,$FIND(X,"")),1:$EXTRACT(X))

 +12       if ORREQ'=ORREQ("O")

               SET ORREQ("O")=ORREQ

               SET ORREQ("F")=1

               SET ORREQ("TIT",0)=""

 +13       if 'ORREQ("F")&(ORREQ=ORREQ("O"))

               SET ORREQ="    """

 +14       SET ORREQ("F")=0

 +15       if ORREQ("TIT")'=$GET(ORREQ("TIT",0))

               SET ORREQ("TIT",0)=ORREQ("TIT")

               SET ORREQ("F")=1

 +16       if 'ORREQ("F")&(ORREQ("TIT")=ORREQ("TIT",0))

               SET ORREQ("TIT")="    """

 +17       SET ORREQ("F")=0

STS       ;

 +1        SET ORSTS=$SELECT($GET(ORASTS)!(ORSTS):" "_$PIECE(^ORD(100.01,$SELECT($GET(ORASTS):ORASTS,1:ORSTS),.1),"^"),1:" ")

 +2        if '$DATA(ORTERM(5))

               DO TERM^ORPRS01(IOST)

 +3        SET ORFLAG=$$FLAG^ORPRS03(ORIFN,ORTERM(5))

 +4        SET ORXPND=$ORDER(ORTX(""),-1)

 +5        DO PGCHK(ORXPND+1)

 +6        if OREND

               QUIT

 +7        WRITE !!

 +8        SET X=$PIECE(ORTERM(7),"^")

 +9        if OREL

               SET X=$$INV^ORU

 +10       if $LENGTH(ORODT)

               WRITE $EXTRACT(ORODT,4,5)_"/"_$EXTRACT(ORODT,6,7)_"/"_$EXTRACT(ORODT,2,3)

 +11       WRITE ?8,ORSTS,?12,$SELECT(ORDAD:"+",1:" ")

 +12       if $ORDER(ORTX(0))

               WRITE ORTX($ORDER(ORTX(0)))

 +13       WRITE ?54,ORREQ

           if $LENGTH(ORSTRT)

               WRITE ?65,$EXTRACT(ORSTRT,4,5)_"/"_$EXTRACT(ORSTRT,6,7)_"/"_$EXTRACT(ORSTRT,2,3)

 +14       if $LENGTH(ORSTOP)

               WRITE ?75,$EXTRACT(ORSTOP,4,5)_"/"_$EXTRACT(ORSTOP,6,7)

 +15       WRITE !?3,$$MTIM(ORODT),?13

 +16       SET X=$ORDER(ORTX(0))

 +17       IF X

               if $ORDER(ORTX(X))

                   WRITE ORTX($ORDER(ORTX(X)))

 +18       WRITE ?54,$EXTRACT(ORREQ("TIT"),1,10),?68,$$MTIM(ORSTRT),?75,$$MTIM(ORSTOP)

 +19       SET X=0

           FOR I=1:1

               SET X=$ORDER(ORTX(X))

               if 'X

                   QUIT

               IF I>2

                   WRITE !?13,ORTX(X)

                   if ($Y>(IOSL-5))

                       DO PGCHK(ORXPND-I)

                   if OREND

                       QUIT

 +20       if OREND

               QUIT

 +21       WRITE !

 +22       IF $$GET^XPAR("ALL","ORPF INITIALS ON SUMMARY",1,"I")

               IF ORUSER

                   WRITE ?1,$PIECE($GET(^VA(200,ORUSER,0)),"^",2)

 +23       IF $DATA(^OR(100,ORIFN,8,OACTION,0))

               SET X=^(0)

               Begin DoDot:1

 +24               NEW NATURE,SIGSTS,NURSE,REVIEW

 +25               SET SIGSTS=$PIECE(X,"^",4)

                   SET NATURE=$PIECE(X,"^",12)

                   SET NURSE=$PIECE(X,"^",8)

                   SET REVIEW=$PIECE(X,"^",18)

 +26               IF $LENGTH(SIGSTS)

                       SET SIGSTS=$$SET(100.008,4,SIGSTS)

 +27               IF NATURE

                       SET NATURE=$PIECE($GET(^ORD(100.02,NATURE,0)),"^")

 +28               IF NURSE

                       SET NURSE=$PIECE($GET(^VA(200,NURSE,0)),"^",2)

 +29               IF REVIEW

                       SET REVIEW=$PIECE($GET(^VA(200,REVIEW,0)),"^",2)

 +30               if $LENGTH(NURSE)

                       WRITE ?9,"Nrs:"_NURSE

 +31               if $LENGTH(REVIEW)

                       WRITE ?19,"Chrt:"_REVIEW

 +32               if $LENGTH(NATURE)

                       WRITE ?30,"Typ:"_$EXTRACT(NATURE,1,18)

 +33               if $LENGTH(SIGSTS)

                       WRITE ?54,"Sgn:"_$EXTRACT(SIGSTS,1,25)

               End DoDot:1

 +34       IF $DATA(^OR(100,ORIFN,5,0))

               SET J=0

FOR

                   SET J=$ORDER(^OR(100,ORIFN,5,J))

                   if 'J

                       QUIT

                   WRITE !?13,^(J,0)

 +35       IF ORDAD

               Begin DoDot:1

 +36               NEW I,ORSEQ

 +37               SET I=0

                   SET ORSEQ=0

                   SET ORTIT(0)=ORTIT

 +38               DO KIDS(ORIFN)

 +39               SET ORTIT=ORTIT(0)

               End DoDot:1

               if OREND

                   QUIT

 +40       IF OREL

               WRITE !?66,"*UNRELEASED*"

               SET X=$PIECE(ORTERM(7),U,3)

               SET X=$$INV^ORU

 +41       SET ORSPG("LAST")='$ORDER(^TMP("ORR",$JOB,ORLIST,ORLST))

           SET ORCONT='ORSPG("LAST")

 +42       DO PGCHK()

 +43       QUIT

PGCHK(CNT) ;

 +1        NEW DIR,X,I

 +2        if '$DATA(CNT)

               SET CNT=0

 +3        IF $GET(ORSPG("LAST"))

               WRITE !!,?32,"* END OF ORDERS *"

               if '$GET(ORSHORT)

                   WRITE !,ORLINE

               Begin DoDot:1

 +4                IF $EXTRACT(IOST)="P"

                       DO PBOT^ORPRS05(ORSPG,IOSL,ORPNM,ORSSN,ORDOB,ORAGE,$GET(ORPD),ORL(0),ORL(1),$GET(ORSHORT))

                       IF '$GET(ORSHORT)!($Y+15>IOSL)

                           WRITE @IOF

 +5                IF $EXTRACT(IOST)="C"

                       WRITE !

                       SET DIR(0)="FO^1;2"

                       SET DIR("A")="Press RETURN to continue, '^' to exit"

                       DO ^DIR

                       IF $DATA(DUOUT)

                           SET OREND=1

                           QUIT

               End DoDot:1

 +6        IF $GET(ORSEND)

               IF $GET(ORLSTO)

                   Begin DoDot:1

 +7                    WRITE !?(IOM-44)\2,"*****    E N D    O F    R E P O R T    ****",!

 +8                    IF $EXTRACT(IOST)="C"

                           WRITE !

                           SET DIR(0)="FO^1;2"

                           SET DIR("A")="Press RETURN to continue, '^' to exit"

                           DO ^DIR

                           IF $DATA(DUOUT)

                               SET OREND=1

                               QUIT

                   End DoDot:1

                   KILL ORSEND,ORCONT

                   QUIT

 +9        IF $GET(ORSPG("LAST"))

               QUIT

 +10       IF $EXTRACT(IOST)="C"

               Begin DoDot:1

 +11               IF ((IOSL-$Y)>(4+CNT))!(CNT+4>(IOSL-3))

                       QUIT

 +12               SET ORSPG=$GET(ORSPG)+1

 +13               WRITE !

 +14               SET DIR(0)="FO^1;2"

                   SET DIR("A")="Press RETURN to continue or '^' to exit"

 +15               DO ^DIR

 +16               IF $DATA(DUOUT)

                       KILL ORSEND,ORCONT

                       SET OREND=1

                       QUIT

 +17               DO CTOP^ORPRS05(ORSPG,$GET(ORSEND),$GET(ORSPG("EOP")),ORTIT,ORSHORT,ORL(0),ORL(1),ORWARD,ORPNM,ORSSN,ORDOB,ORAGE,$GET(ORPD))

 +18               SET ORSPG=0

 +19               IF $GET(ORCONT)

                       DO PTHDR

               End DoDot:1

               QUIT

 +20       IF ((IOSL-$Y)>(6+CNT))!(CNT+6>(IOSL-5))

               QUIT

 +21       DO PBOT^ORPRS05(ORSPG,IOSL,ORPNM,ORSSN,ORDOB,ORAGE,$GET(ORPD),ORL(0),ORL(1),$GET(ORSHORT))

 +22       SET ORSPG=ORSPG+1

 +23       WRITE @IOF

 +24       DO PTOP^ORPRS05(ORSPG,ORTIT,ORSHORT,ORSSTRT,ORSSTOP)

 +25       IF $GET(ORCONT)

               DO PTHDR

 +26       QUIT

PTHDR     ;

 +1        WRITE !,ORPNM_"   "_$GET(ORSSN)_" "_$SELECT($GET(ORCONT):"(cont.)",1:"")_" "

 +2        SET X=$PIECE(ORWARD,"^",2)_"  "_ORL(1)

 +3        WRITE ?(80-$LENGTH(X))\2,X

 +4        QUIT

KIDS(ORIFN,LENGTH) ;Print child orders

 +1        NEW ORCHLD,OROIFN

 +2        SET OROIFN=ORIFN

           SET ORCHLD=0

 +3        FOR I=0:0

               SET ORCHLD=$ORDER(^OR(100,OROIFN,2,ORCHLD))

               if ORCHLD<1

                   QUIT

               DO PGCHK()

               if OREND

                   QUIT

               SET ORIFN=ORCHLD

               DO ONE^ORPRS03(ORCHLD,"         ",$GET(LENGTH))

 +4        QUIT

MTIM(X)   ;Format time from Fileman date in X

 +1        IF '$GET(X)

               QUIT ""

 +2        SET X=$PIECE(X,".",2)

 +3        if '$LENGTH(X)

               QUIT ""

 +4        SET X=$EXTRACT(X,1,2)_$EXTRACT("00",0,2-$LENGTH($EXTRACT(X,1,2)))_":"_$EXTRACT(X,3,4)_$EXTRACT("00",0,2-$LENGTH($EXTRACT(X,3,4)))

 +5        QUIT X

SET(FILE,FIELD,RESULT) ;Interpret set of codes

 +1        SET X=$PIECE(^DD(FILE,FIELD,0),"^",3)

           SET X=$PIECE($PIECE(";"_X,";"_RESULT_":",2),";")

 +2        QUIT X

ORPRS04.m