ORPRS04 ; slc/dcm - Print Order summaries (SHRIVELED) ;12-Apr-2011 13:39;DU
;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,69,92,121,1008**;Dec 17, 1997;Build 47
; Modified - IHS/MSC/PLS - 04/12/11 - PRT+8
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()
Q
PRT ;Print order line
N ORDIA,NVA,ORDIAI,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:"")
;IHS/MSC/MGH Added change for requestor to null for NVA meds
S ORDIA=$P(X,"^",5),ORDIAI=$P(ORDIA,";",1)
S NVA=$O(^ORD(101.41,"B","PSH OERR",""))
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))
;IHS/MSC/MGH added change for requestor to null for NVA meds
I ORDIAI=NVA S ORREQ="N/A",ORREQ("TIT")=" ",ORREQ("TIT",0)=""
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(^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()
Q
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
Q
PTHDR ;
W !,ORPNM_" "_$G(ORSSN)_" "_$S($G(ORCONT):"(cont.)",1:"")_" "
S X=$P(ORWARD,"^",2)_" "_ORL(1)
W ?(80-$L(X))\2,X
Q
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))
Q
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
ORPRS04 ; slc/dcm - Print Order summaries (SHRIVELED) ;12-Apr-2011 13:39;DU
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,69,92,121,1008**;Dec 17, 1997;Build 47
+2 ; Modified - IHS/MSC/PLS - 04/12/11 - PRT+8
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 ORDIA,NVA,ORDIAI,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 ;IHS/MSC/MGH Added change for requestor to null for NVA meds
+9 SET ORDIA=$PIECE(X,"^",5)
SET ORDIAI=$PIECE(ORDIA,";",1)
+10 SET NVA=$ORDER(^ORD(101.41,"B","PSH OERR",""))
+11 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:"")
+12 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")=" "
+13 DO TEXT^ORQ12(.ORTX,$SELECT($GET(OACTION):ORIFN_";"_OACTION,1:ORIFN),40)
+14 SET X=$PIECE(ORREQ,",",2)
SET ORREQ=$EXTRACT($PIECE(ORREQ,","),1,8)_","_$SELECT($EXTRACT(X)=" ":$EXTRACT(X,$FIND(X,"")),1:$EXTRACT(X))
+15 ;IHS/MSC/MGH added change for requestor to null for NVA meds
+16 IF ORDIAI=NVA
SET ORREQ="N/A"
SET ORREQ("TIT")=" "
SET ORREQ("TIT",0)=""
+17 IF ORREQ'=ORREQ("O")
SET ORREQ("O")=ORREQ
SET ORREQ("F")=1
SET ORREQ("TIT",0)=""
+18 IF 'ORREQ("F")&(ORREQ=ORREQ("O"))
SET ORREQ=" """
+19 SET ORREQ("F")=0
+20 IF ORREQ("TIT")'=$GET(ORREQ("TIT",0))
SET ORREQ("TIT",0)=ORREQ("TIT")
SET ORREQ("F")=1
+21 IF 'ORREQ("F")&(ORREQ("TIT")=ORREQ("TIT",0))
SET ORREQ("TIT")=" """
+22 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(^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
