ORPRS11 ; slc/dcm - Alternate lifestyle for Summary Reports ;12/7/00 13:13
;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,92**;Dec 17, 1997
;Sorts by display group, using the Summary Order display group for
;the order. Loops on the AW x-ref, sorted by forward Start date.
;Not currently in use!!!
;The lookup on the AW x-ref needs to be changed to call ^ORQ1 with
;the display group SUMMARY ORDER, then another sort needs to be done
;on the returned array to sort on the Summary Order sequence and
;the start time.
IN ;START
Q ;Not ready for primetime.
S (OREND,ORANSI,ORSPG)=0
D:$D(ORSCPAT)'>9 P^ORPRS01
G:OREND!'$D(ORSCPAT) END
D PRES^ORPRS09
G:OREND END
D SERV^ORPRS09
G:OREND END
D RANGE^ORPRS01()
G:OREND END
S ORTIT=$P(ORPRES,";",2)_" for "_ORGRP("NAM")_" SERVICES"
CONT ;
D QUE^ORUTL1("EN1^ORPRS11","Alternate Order Summary Report"),END
Q
EN1 ;Entry point for Batch Processing
U IO
I +ORPRES=2 S %DT="",X="T-1" D ^%DT S ORYD=Y
I +ORPRES=6 S %DT="",X="T+1" D ^%DT S ORTMW=Y_".9999"
I $E(IOST)'="C",$L($G(ORSWDN)) S ORSLTR=$E(ORSWDN,1,(IOM\15)) D ^ORSLTR
S (NEXTP,OREND)=0
F S NEXTP=$O(ORSCPAT(NEXTP)) Q:NEXTP=""!(OREND=1) S ORVP=+ORSCPAT(NEXTP)_";DPT(" D EN Q:OREND D PGBRK^ORUHDR:$E(IOST)="C" Q:OREND
END ; Clean up variables
K ^TMP("ORR",$J),ORSLTR,ORANSI,ORATTEND,ORDAD,ORDOG,ORDOGY,ORFLAG,ORI,ORSCPAT,ORSUM,ORTERM,ORYD,ORTMW,X2,X3,XQORSPEW,ORURMBD,ORPRTD,ORSHORT
K I,II,J,K,NEXTP,NB,ND,NS,ORES,ODATE,ORAGE,ORDCFC,ORMD,ORDG,ORDIC,ORDOB,OREND,ORFT,ORGRP,ORH,ORH2,ORHI,ORIO,ORL,ORLST,ORODT,ORNP,ORPD,ORPFG,ORPNM,ORPRES,ORUSER,ORPV,ORREQ,ORSPG
K ORSEL,ORSEQ,ORSEX,ORSP,ORSPAT,ORSPL,ORSSN,ORSSTOP,ORSSTRT,ORSTRT,ORSTOP,ORSTS,ORASTS,ORTIT,ORTM,ORTS,ORTX,ORVP,ORWARD,ORX,X,X1,Y,%,%DT,%IS,ORSWD,ORSWDN,ORRPG,ORIFN
I $D(ZTSK) D KILL^%ZTLOAD K ZTSK
Q
EN ;
I '$D(^OR(100,"AW",ORVP)) W !!,"NO ORDERS FOUND",!! Q
S Y=+ORVP,ORSPG("EOP")=0
D END^ORUDPA
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))
I $E(IOST)'="C" D Q:OREND
. D PGCHK Q:OREND
. D PTOP^ORPRS05(ORSPG,ORTIT,ORSHORT,ORSSTRT,ORSSTOP),PTHDR
I ORSPG("EOP")'=1 D PGCHK Q:OREND
K ORPRTD
S ORSUM=$O(^ORD(100.98,"B","SUMMARY ORDER",0))
Q:'ORSUM
S ORDOG=0
F S ORDOG=$O(^ORD(100.98,ORSUM,1,ORDOG)) Q:'ORDOG S ORDOGY=+^(ORDOG,0) I $D(^OR(100,"AW",ORVP,ORDOGY)) D Q:OREND
. D PGCHK,PGCHK1
. W !!,$P(^ORD(100.98,ORDOGY,0),"^")
. S X="",$P(X,"-",$L($P(^(0),"^"))+1)=""
. W !,X
. S ORTM=$S($D(ORSSTRT):+ORSSTRT,1:0)
. F S ORTM=$O(^OR(100,"AW",ORVP,ORDOGY,ORTM)) Q:'ORTM!(ORTM>+ORSSTOP) D Q:OREND
.. S ORIFN=0
.. F S ORIFN=$O(^OR(100,"AW",ORVP,ORDOGY,ORTM,ORIFN)) Q:'ORIFN D Q:OREND
... D PGCHK,PGCHK1
... Q:OREND
... D PRT
... S ORPRTD=1
I $G(ORPRTD),$E(IOST)'="C" S X="",$P(X,"-",IOM)="" W !,X D PBOT^ORPRS05(1,ORBOT,ORPNM,ORSSN,ORDOB,ORAGE,$G(ORPD),ORL(0),ORL(1))
Q
PRT ;Print order line
K ORTX
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(X0,"^",8),ORMD=$P(X3,"^",10)
I $G(OACTION) I $D(^OR(100,ORIFN,8,OACTION,0)) S X=^(0),ORODT=+X,ORREQ=$P(X,"^",3),ORMD=$P(X,"^",4),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")
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))
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))
W !
S X=$P(ORTERM(7),"^")
S:OREL X=$$INV^ORU
W:$L(ORODT) ?2,$E(ORODT,4,5),"/",$E(ORODT,6,7)
W ?9,ORSTS
W ?11,$S(ORDAD:"+",1:" ")
W:$O(ORTX(0)) ORTX($O(ORTX(0)))
W ?54,ORREQ
W:$L(ORSTRT) ?64,$E(ORSTRT,4,5),"/",$E(ORSTRT,6,7)
W:$L(ORSTOP) ?74,$E(ORSTOP,4,5),"/",$E(ORSTOP,6,7)
W !?2,$$MTIM^ORPRS04(ORODT),?12
S X=$O(ORTX(0))
I X W:$O(ORTX(X)) ORTX($O(ORTX(X)))
W ?67,$$MTIM^ORPRS04(ORSTRT),?74,$$MTIM^ORPRS04(ORSTOP)
S X=0 F I=1:1 S X=$O(ORTX(X)) Q:X'>0 I I>2 W !?12,ORTX(X)
I $D(^OR(100,ORIFN,5,0)) S J=0 F I=0:0 S J=$O(^OR(100,ORIFN,5,J)) Q:J<1 W !?12,^(J,0)
I ORDAD D
. S ORSEQ=0 D PRT1 K ORSEQ
I OREL W !?66,"*UNRELEASED*" S X=$P(ORTERM(7),"^",3),X=$$INV^ORU
K OREL Q
PGCHK ;
S ORSPG("EOP")=0
Q:(IOSL-$Y)'<8
S ORSPG("EOP")=1
I ORSPG("EOP"),$E(IOST)="C" D WAIT
Q
PGCHK1 ;
I $E(IOST)'="C",(IOSL-$Y)<8 S X="",$P(X,"-",IOM)="" W !,X D PBOT^ORPRS05(1,ORBOT,ORPNM,ORSSN,ORDOB,ORAGE,$G(ORPD),ORL(0),ORL(1)),PTOP^ORPRS05(ORSPG,ORTIT,ORSHORT,ORSSTRT,ORSSTOP),PTHDR W !
Q
WAIT ;
W !!,"Press RETURN to continue, '^' to escape"
R X:DTIME
S:'$T X="^"
S:X["^" OREND=1
D:'OREND CTOP^ORPRS05(ORSPG,$G(ORSEND),$G(ORSPG("EOP")),ORTIT,ORSHORT,ORL(0),ORL(1),ORWARD,ORPNM,ORSSN,ORDOB,ORAGE,$G(ORPD))
W:OREND @IOF
Q
PRT1 ;
S OROSEQ=$G(ORSEQ),OROIFN=ORIFN,ORCHLD=0
F I=0:0 S ORCHLD=$O(^OR(100,OROIFN,2,ORCHLD)) Q:ORCHLD<1 D PGCHK,PGCHK1 Q:OREND S ORIFN=ORCHLD,ORSEQ=" " D ONE^ORPRS03(ORIFN," ")
S ORIFN=OROIFN,ORSEQ=OROSEQ
K OROIFN,OROSEQ,ORCHLD
Q
PTHDR ;
W !,ORPNM," "
S X=$P(ORWARD,"^",2)_" "_ORL(1)
W ?(80-$L(X)/2),X,?68,$G(ORSSN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORPRS11 5394 printed Dec 13, 2024@02:32:58 Page 2
ORPRS11 ; slc/dcm - Alternate lifestyle for Summary Reports ;12/7/00 13:13
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,92**;Dec 17, 1997
+2 ;Sorts by display group, using the Summary Order display group for
+3 ;the order. Loops on the AW x-ref, sorted by forward Start date.
+4 ;Not currently in use!!!
+5 ;The lookup on the AW x-ref needs to be changed to call ^ORQ1 with
+6 ;the display group SUMMARY ORDER, then another sort needs to be done
+7 ;on the returned array to sort on the Summary Order sequence and
+8 ;the start time.
IN ;START
+1 ;Not ready for primetime.
QUIT
+2 SET (OREND,ORANSI,ORSPG)=0
+3 if $DATA(ORSCPAT)'>9
DO P^ORPRS01
+4 if OREND!'$DATA(ORSCPAT)
GOTO END
+5 DO PRES^ORPRS09
+6 if OREND
GOTO END
+7 DO SERV^ORPRS09
+8 if OREND
GOTO END
+9 DO RANGE^ORPRS01()
+10 if OREND
GOTO END
+11 SET ORTIT=$PIECE(ORPRES,";",2)_" for "_ORGRP("NAM")_" SERVICES"
CONT ;
+1 DO QUE^ORUTL1("EN1^ORPRS11","Alternate Order Summary Report")
DO END
+2 QUIT
EN1 ;Entry point for Batch Processing
+1 USE IO
+2 IF +ORPRES=2
SET %DT=""
SET X="T-1"
DO ^%DT
SET ORYD=Y
+3 IF +ORPRES=6
SET %DT=""
SET X="T+1"
DO ^%DT
SET ORTMW=Y_".9999"
+4 IF $EXTRACT(IOST)'="C"
IF $LENGTH($GET(ORSWDN))
SET ORSLTR=$EXTRACT(ORSWDN,1,(IOM\15))
DO ^ORSLTR
+5 SET (NEXTP,OREND)=0
+6 FOR
SET NEXTP=$ORDER(ORSCPAT(NEXTP))
if NEXTP=""!(OREND=1)
QUIT
SET ORVP=+ORSCPAT(NEXTP)_";DPT("
DO EN
if OREND
QUIT
if $EXTRACT(IOST)="C"
DO PGBRK^ORUHDR
if OREND
QUIT
END ; Clean up variables
+1 KILL ^TMP("ORR",$JOB),ORSLTR,ORANSI,ORATTEND,ORDAD,ORDOG,ORDOGY,ORFLAG,ORI,ORSCPAT,ORSUM,ORTERM,ORYD,ORTMW,X2,X3,XQORSPEW,ORURMBD,ORPRTD,ORSHORT
+2 KILL I,II,J,K,NEXTP,NB,ND,NS,ORES,ODATE,ORAGE,ORDCFC,ORMD,ORDG,ORDIC,ORDOB,OREND,ORFT,ORGRP,ORH,ORH2,ORHI,ORIO,ORL,ORLST,ORODT,ORNP,ORPD,ORPFG,ORPNM,ORPRES,ORUSER,ORPV,ORREQ,ORSPG
+3 KILL ORSEL,ORSEQ,ORSEX,ORSP,ORSPAT,ORSPL,ORSSN,ORSSTOP,ORSSTRT,ORSTRT,ORSTOP,ORSTS,ORASTS,ORTIT,ORTM,ORTS,ORTX,ORVP,ORWARD,ORX,X,X1,Y,%,%DT,%IS,ORSWD,ORSWDN,ORRPG,ORIFN
+4 IF $DATA(ZTSK)
DO KILL^%ZTLOAD
KILL ZTSK
+5 QUIT
EN ;
+1 IF '$DATA(^OR(100,"AW",ORVP))
WRITE !!,"NO ORDERS FOUND",!!
QUIT
+2 SET Y=+ORVP
SET ORSPG("EOP")=0
+3 DO END^ORUDPA
+4 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))
+5 IF $EXTRACT(IOST)'="C"
Begin DoDot:1
+6 DO PGCHK
if OREND
QUIT
+7 DO PTOP^ORPRS05(ORSPG,ORTIT,ORSHORT,ORSSTRT,ORSSTOP)
DO PTHDR
End DoDot:1
if OREND
QUIT
+8 IF ORSPG("EOP")'=1
DO PGCHK
if OREND
QUIT
+9 KILL ORPRTD
+10 SET ORSUM=$ORDER(^ORD(100.98,"B","SUMMARY ORDER",0))
+11 if 'ORSUM
QUIT
+12 SET ORDOG=0
+13 FOR
SET ORDOG=$ORDER(^ORD(100.98,ORSUM,1,ORDOG))
if 'ORDOG
QUIT
SET ORDOGY=+^(ORDOG,0)
IF $DATA(^OR(100,"AW",ORVP,ORDOGY))
Begin DoDot:1
+14 DO PGCHK
DO PGCHK1
+15 WRITE !!,$PIECE(^ORD(100.98,ORDOGY,0),"^")
+16 SET X=""
SET $PIECE(X,"-",$LENGTH($PIECE(^(0),"^"))+1)=""
+17 WRITE !,X
+18 SET ORTM=$SELECT($DATA(ORSSTRT):+ORSSTRT,1:0)
+19 FOR
SET ORTM=$ORDER(^OR(100,"AW",ORVP,ORDOGY,ORTM))
if 'ORTM!(ORTM>+ORSSTOP)
QUIT
Begin DoDot:2
+20 SET ORIFN=0
+21 FOR
SET ORIFN=$ORDER(^OR(100,"AW",ORVP,ORDOGY,ORTM,ORIFN))
if 'ORIFN
QUIT
Begin DoDot:3
+22 DO PGCHK
DO PGCHK1
+23 if OREND
QUIT
+24 DO PRT
+25 SET ORPRTD=1
End DoDot:3
if OREND
QUIT
End DoDot:2
if OREND
QUIT
End DoDot:1
if OREND
QUIT
+26 IF $GET(ORPRTD)
IF $EXTRACT(IOST)'="C"
SET X=""
SET $PIECE(X,"-",IOM)=""
WRITE !,X
DO PBOT^ORPRS05(1,ORBOT,ORPNM,ORSSN,ORDOB,ORAGE,$GET(ORPD),ORL(0),ORL(1))
+27 QUIT
PRT ;Print order line
+1 KILL ORTX
+2 if '$DATA(^OR(100,ORIFN,0))
QUIT
SET X=^(0)
SET X3=$SELECT($DATA(^(3)):^(3),1:"")
SET ORDAD=$ORDER(^(2,0))
+3 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(X0,"^",8)
SET ORMD=$PIECE(X3,"^",10)
+4 IF $GET(OACTION)
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 ORUSER=$PIECE(X,"^",13)
SET ORASTS=$PIECE(X,"^",15)
SET OREL=$SELECT(ORASTS=11:1,1:"")
+5 SET ORREQ=$SELECT(ORREQ:$SELECT($DATA(^VA(200,ORREQ,0)):$PIECE(^(0),"^"),1:"UNKNOWN"),1:"UNKNOWN")
+6 DO TEXT^ORQ12(.ORTX,$SELECT($GET(OACTION):ORIFN_";"_OACTION,1:ORIFN),40)
+7 SET X=$PIECE(ORREQ,",",2)
SET ORREQ=$EXTRACT($PIECE(ORREQ,","),1,8)_","_$SELECT($EXTRACT(X)=" ":$EXTRACT(X,$FIND(X,"")),1:$EXTRACT(X))
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 WRITE !
+5 SET X=$PIECE(ORTERM(7),"^")
+6 if OREL
SET X=$$INV^ORU
+7 if $LENGTH(ORODT)
WRITE ?2,$EXTRACT(ORODT,4,5),"/",$EXTRACT(ORODT,6,7)
+8 WRITE ?9,ORSTS
+9 WRITE ?11,$SELECT(ORDAD:"+",1:" ")
+10 if $ORDER(ORTX(0))
WRITE ORTX($ORDER(ORTX(0)))
+11 WRITE ?54,ORREQ
+12 if $LENGTH(ORSTRT)
WRITE ?64,$EXTRACT(ORSTRT,4,5),"/",$EXTRACT(ORSTRT,6,7)
+13 if $LENGTH(ORSTOP)
WRITE ?74,$EXTRACT(ORSTOP,4,5),"/",$EXTRACT(ORSTOP,6,7)
+14 WRITE !?2,$$MTIM^ORPRS04(ORODT),?12
+15 SET X=$ORDER(ORTX(0))
+16 IF X
if $ORDER(ORTX(X))
WRITE ORTX($ORDER(ORTX(X)))
+17 WRITE ?67,$$MTIM^ORPRS04(ORSTRT),?74,$$MTIM^ORPRS04(ORSTOP)
+18 SET X=0
FOR I=1:1
SET X=$ORDER(ORTX(X))
if X'>0
QUIT
IF I>2
WRITE !?12,ORTX(X)
+19 IF $DATA(^OR(100,ORIFN,5,0))
SET J=0
FOR I=0:0
SET J=$ORDER(^OR(100,ORIFN,5,J))
if J<1
QUIT
WRITE !?12,^(J,0)
+20 IF ORDAD
Begin DoDot:1
+21 SET ORSEQ=0
DO PRT1
KILL ORSEQ
End DoDot:1
+22 IF OREL
WRITE !?66,"*UNRELEASED*"
SET X=$PIECE(ORTERM(7),"^",3)
SET X=$$INV^ORU
+23 KILL OREL
QUIT
PGCHK ;
+1 SET ORSPG("EOP")=0
+2 if (IOSL-$Y)'<8
QUIT
+3 SET ORSPG("EOP")=1
+4 IF ORSPG("EOP")
IF $EXTRACT(IOST)="C"
DO WAIT
+5 QUIT
PGCHK1 ;
+1 IF $EXTRACT(IOST)'="C"
IF (IOSL-$Y)<8
SET X=""
SET $PIECE(X,"-",IOM)=""
WRITE !,X
DO PBOT^ORPRS05(1,ORBOT,ORPNM,ORSSN,ORDOB,ORAGE,$GET(ORPD),ORL(0),ORL(1))
DO PTOP^ORPRS05(ORSPG,ORTIT,ORSHORT,ORSSTRT,ORSSTOP)
DO PTHDR
WRITE !
+2 QUIT
WAIT ;
+1 WRITE !!,"Press RETURN to continue, '^' to escape"
+2 READ X:DTIME
+3 if '$TEST
SET X="^"
+4 if X["^"
SET OREND=1
+5 if 'OREND
DO CTOP^ORPRS05(ORSPG,$GET(ORSEND),$GET(ORSPG("EOP")),ORTIT,ORSHORT,ORL(0),ORL(1),ORWARD,ORPNM,ORSSN,ORDOB,ORAGE,$GET(ORPD))
+6 if OREND
WRITE @IOF
+7 QUIT
PRT1 ;
+1 SET OROSEQ=$GET(ORSEQ)
SET OROIFN=ORIFN
SET ORCHLD=0
+2 FOR I=0:0
SET ORCHLD=$ORDER(^OR(100,OROIFN,2,ORCHLD))
if ORCHLD<1
QUIT
DO PGCHK
DO PGCHK1
if OREND
QUIT
SET ORIFN=ORCHLD
SET ORSEQ=" "
DO ONE^ORPRS03(ORIFN," ")
+3 SET ORIFN=OROIFN
SET ORSEQ=OROSEQ
+4 KILL OROIFN,OROSEQ,ORCHLD
+5 QUIT
PTHDR ;
+1 WRITE !,ORPNM," "
+2 SET X=$PIECE(ORWARD,"^",2)_" "_ORL(1)
+3 WRITE ?(80-$LENGTH(X)/2),X,?68,$GET(ORSSN)
+4 QUIT
