ORPRS11.m

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 ---ORPRS11   5394     printed  Feb 18, 2025@23:59:30                                                                                                                                                                                                     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