PSXRACT ;BIR/HW-ACTIVITY REPORT [ 05/10/97 2:28 PM ] ; 31 Oct 2000 2:28 PM
;;2.0;CMOP;**1,31**;11 Apr 97
; External reference to ^PSRX( supported by DBIA #1221
; External reference to ^PS(59 supported by DBIA #1976
;
BEGDATE S DIR(0)="DO",DIR("A")="ENTER BEGINNING TRANSMISSION DATE " D ^DIR K DIR
G:$D(DIRUT)!(X']"") END
S PSXB=Y K Y,X
I PSXB>DT W !!,"Future dates are not allowed.",! G BEGDATE
ENDDATE S Y=DT X ^DD("DD") S ZZTODAY=Y K Y
K X,Y
S DIR(0)="DO",DIR("A")="ENTER ENDING TRANSMISSION DATE ",DIR("B")=ZZTODAY
D ^DIR K DIR
G:$D(DIRUT) END
S PSXE=Y K Y
I PSXE<PSXB W !,"Ending date must follow beginning date!" G ENDDATE
K ZZTODAY
D SEL Q:'$D(DIVNM)
DEVICE W !! S %ZIS="MQ",%ZIS("A")="Select Printer: ",%ZIS("B")=""
D ^%ZIS G:POP END S PSXLAP=ION
I $E(IOST,1,2)["C-" G START
I '$D(IO("Q")) G ST0
D ^%ZISC K J,C
QUE S ZTSAVE("PSXB")="",ZTSAVE("PSXE")="",ZTSAVE("DIVNM(")="",ZTSAVE("DIVDA(")="",ZTIO=PSXLAP
S ZTRTN="START^PSXRACT"
S ZTDESC="CMOP Activity Report"
D ^%ZTLOAD
Q1 W:$D(ZTSK) !!,"Report Queued to Print!!"
K DIR,PSXB,PSXE,Y
Q
ST0 U IO
;Called by taskman to print the CMOP Activity Report
START S:$D(ZTQUEUED) ZTREQ="@"
S LINE="W ! F I=1:1:80 W ""="""
DIVISION ;
S DIVDA=0 F S DIVDA=$O(DIVDA(DIVDA)) Q:DIVDA'>0 D ONEDIV
D GRNDSUM
G EXIT
;
Q
ONEDIV ;
S LINE="W ! F I=1:1:80 W ""=""",CT=0
S Y=PSXB X ^DD("DD") S PSXBE=Y
S Y=PSXE X ^DD("DD") S PSXEE=Y
S PSXE1=PSXE+.99999,PSXD=PSXB-.00001
D TITLE
BATCH F S PSXD=$O(^PSX(550.2,"D",PSXD)) Q:(+PSXD'>0)!(+PSXD>PSXE1) D Q:$G(PSXFLAG)=1
.F P5502=0:0 S P5502=$O(^PSX(550.2,"D",PSXD,P5502)) Q:'P5502 D Q:$G(PSXFLAG)=1
..S BATCH=+$P($G(^PSX(550.2,P5502,0)),"^") Q:$G(BATCH)']""
..S DIV=$P($G(^PSX(550.2,P5502,0)),"^",3),DIV=$P($G(^PS(59,DIV,0)),"^")
..I '$D(DIVNM(DIV)) Q
..I DIV'=DIVDA(DIVDA) Q
..S NODE=$G(^PSX(550.2,P5502,1)) Q:$G(NODE)']""
..S ORDS=$P($G(NODE),"^",7),TORDS=$G(TORDS)+ORDS,RTRN=$P(NODE,"^",2)
..S TORDS(DIV)=$G(TORDS(DIV))+ORDS
..S RXS=$P($G(NODE),"^",8),TRXS=$G(TRXS)+RXS
..S TRXS(DIV)=$G(TRXS(DIV))+RXS
..F PSXR=0:0 S PSXR=$O(^PSRX("AS",PSXD,PSXR)) Q:'PSXR D
...S PSXF="" F S PSXF=$O(^PSRX("AS",PSXD,PSXR,PSXF)) Q:($G(PSXF)']"") D RX
..D PRINT Q:$G(PSXFLAG)=1
X LINE
S DIV=DIVDA(DIVDA)
W !,?9,DIV,?35,$J($G(TORDS(DIV)),7),?43,$J($G(TRXS(DIV)),6),?53,$J($G(PSXCRT(DIV)),7),?63,$J($G(PSXNDT(DIV)),7),?73,$J($G(PSXCUT(DIV)),5)
Q
GRNDSUM ;
S DIVDA(0)=" Grand Total Summary",DIVDA=0
D TITLE
S DIV=0 F S DIV=$O(TORDS(DIV)) Q:DIV="" D
.W !,?9,DIV,?35,$J($G(TORDS(DIV)),7),?43,$J($G(TRXS(DIV)),6),?53,$J($G(PSXCRT(DIV)),7),?63,$J($G(PSXNDT(DIV)),7),?73,$J($G(PSXCUT(DIV)),5)
X LINE
W !!,"TOTAL",?35,$J($G(TORDS),7),?43,$J($G(TRXS),6),?53,$J($G(PSXCRT),7),?63,$J($G(PSXNDT),7),?73,$J($G(PSXCUT),5)
END K DIR,DIRUT,PSXB,PSXE,ZZTODAY,PSXLAP,PSXE1,PSXOT,PSXD,P5502,BATCH
K DIV,NODE,TORDS,TRXS,PSXR,PSXF,GT,PSXFLAG,ZNODE,ZFILL,PSXSTAT,PSXCR
K PSX,PSXCRT,PSXCUT,PSXLINE,PSXNDT,PSXNOW,X,Y,%,RTRN
Q
EXIT ;
D END
K DIVDA,DIVNM,PSXB,PSXE,LINE,CT,I,PSXBE,PSXEE,ZZTOT,ZTSK
D ^%ZISC
Q
RX ; COUNT RX DATA
I $D(^PSRX(PSXR,4,0)) F PSX=0:0 S PSX=$O(^PSRX(PSXR,4,PSX)) Q:'PSX D
.S ZNODE=$G(^PSRX(PSXR,4,PSX,0)),ZFILL=$P($G(ZNODE),"^",3)
.I $G(ZFILL)'=PSXF K ZFILL Q
.I +$G(ZNODE)'=BATCH Q
.S PSXSTAT=$P($G(ZNODE),"^",4),PSX(ZFILL)=PSXSTAT
.K ZNODE,ZFILL,PSXSTAT
I $G(PSX(PSXF))=1 S PSXCR=$G(PSXCR)+1,PSXCRT=$G(PSXCRT)+1 D Q
.S PSXCRT(DIV)=$G(PSXCRT(DIV))+1
I $G(PSX(PSXF))=3 S PSXND=$G(PSXND)+1,PSXNDT=$G(PSXNDT)+1 D Q
.S PSXNDT(DIV)=$G(PSXNDT(DIV))+1
I $G(PSX(PSXF))=2 S PSXRT=$G(PSXRT)+1 S:(RTRN)>0 COM="FILLED IN "_$G(RTRN)
S PSXCU=$G(PSXCU)+1,PSXCUT=$G(PSXCUT)+1
S PSXCUT(DIV)=$G(PSXCUT(DIV))+1
S:$G(COM)'="" PSXCU=""
Q
TITLE I IOST["C-" W @IOF
S Y=PSXB X ^DD("DD") S PSXBP=Y
S Y=PSXE X ^DD("DD") S PSXEP=Y
D NOW^%DTC S Y=% X ^DD("DD") S PSXNOW=Y
W !,?30,"CMOP ACTIVITY REPORT"_$S($G(ZZTOT)=1:" SUMMARY",1:"")
W !,DIVDA(DIVDA)
W !,"For ",PSXBP," thru ",$P(PSXEP,"@"),?40,"Printed: ",PSXNOW
S PSXLINE=6
K PSXBP,PSXEP
X LINE
AHEAD W !,"TRANS #",?9,"DIVISION",?37,"ORDERS",?45,"RXS",?53,"RELEASED",?63,"NOT DISP",?73,"UNREL"
X LINE
Q
PRINT I IOST["C-",($G(PSXLINE)>20) D Q:$G(PSXFLAG)=1
.S DIR(0)="E" D ^DIR K DIR I $G(Y)'=1 S PSXFLAG=1 K Y Q
.D TITLE
I IOST'["C-",($G(PSXLINE)>60) W @IOF D TITLE
;S:$G(COM)="" PSXCU=""
W !,$J($G(BATCH),6),?9,$S($G(COM)'="":$E($G(DIV),1,10)_" "_$G(COM),1:$G(DIV)),?35,$J($G(ORDS),7),?43,$J($G(RXS),6),?53,$J($G(PSXCR),7),?63,$J($G(PSXND),7),?73,$J($G(PSXCU),5)
S PSXLINE=$G(PSXLINE)+1
K BATCH,DIV,ORDS,RXS,PSXCR,PSXND,PSXCU,PSXRT,COM,COM1
Q
SEL ;Select divisions
; returns arrays
; DIVNM("names of divisions")=selection number
; DIVDA("iens of divisions")=name of division
; for testing
W !!,"SELECTION OF DIVISION(S)",!
S DIV="" K DIVNM,DIVDA,DIVX
F I=1:1 S DIV=$O(^PS(59,"B",DIV)) Q:DIV="" S DIVNM(I)=DIV,DIVNM(DIV)=I,DIVDA=$O(^PS(59,"B",DIV,0)),DIVNM(I,"I")=DIVDA
S I=I-1
K DIR S DIR(0)="S^A:ALL DIVISIONS;S:SELECT DIVISIONS"
D ^DIR K DIR G:Y="A" ALL
G:Y="S" SELECT
Q
SELECT ;
F C=1:1:I S DIR("A",C)=C_" "_DIVNM(C)
S DIR(0)="LO^1:"_I,DIR("A")="Select Division(s) "
D ^DIR
I '+Y K DIVNM Q
M DIVX=DIVNM K DIVNM
F I=1:1 S X=$P(Y,",",I) Q:'X M DIVNM(X)=DIVX(X) S DIVNM=DIVX(X),DIVNM(DIVNM)=X
K DIVX,DIR
ALL W !!,"You have selected:",! S DIV=0 F S DIV=$O(DIVNM(DIV)) Q:'DIV W !,DIV,?5,DIVNM(DIV)
S DIR(0)="Y",DIR("A")="Is this corrrect ? ",DIR("B")="YES" D ^DIR
K DIR
I Y D Q
.K DIVDA
.S DIV=0 F S DIV=$O(DIVNM(DIV)) Q:'DIV S DA=DIVNM(DIV,"I"),DIVDA(DA)=DIVNM(DIV) K DIVNM(DIV)
G SEL
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXRACT 5711 printed Sep 23, 2025@19:20:45 Page 2
PSXRACT ;BIR/HW-ACTIVITY REPORT [ 05/10/97 2:28 PM ] ; 31 Oct 2000 2:28 PM
+1 ;;2.0;CMOP;**1,31**;11 Apr 97
+2 ; External reference to ^PSRX( supported by DBIA #1221
+3 ; External reference to ^PS(59 supported by DBIA #1976
+4 ;
BEGDATE SET DIR(0)="DO"
SET DIR("A")="ENTER BEGINNING TRANSMISSION DATE "
DO ^DIR
KILL DIR
+1 if $DATA(DIRUT)!(X']"")
GOTO END
+2 SET PSXB=Y
KILL Y,X
+3 IF PSXB>DT
WRITE !!,"Future dates are not allowed.",!
GOTO BEGDATE
ENDDATE SET Y=DT
XECUTE ^DD("DD")
SET ZZTODAY=Y
KILL Y
+1 KILL X,Y
+2 SET DIR(0)="DO"
SET DIR("A")="ENTER ENDING TRANSMISSION DATE "
SET DIR("B")=ZZTODAY
+3 DO ^DIR
KILL DIR
+4 if $DATA(DIRUT)
GOTO END
+5 SET PSXE=Y
KILL Y
+6 IF PSXE<PSXB
WRITE !,"Ending date must follow beginning date!"
GOTO ENDDATE
+7 KILL ZZTODAY
+8 DO SEL
if '$DATA(DIVNM)
QUIT
DEVICE WRITE !!
SET %ZIS="MQ"
SET %ZIS("A")="Select Printer: "
SET %ZIS("B")=""
+1 DO ^%ZIS
if POP
GOTO END
SET PSXLAP=ION
+2 IF $EXTRACT(IOST,1,2)["C-"
GOTO START
+3 IF '$DATA(IO("Q"))
GOTO ST0
+4 DO ^%ZISC
KILL J,C
QUE SET ZTSAVE("PSXB")=""
SET ZTSAVE("PSXE")=""
SET ZTSAVE("DIVNM(")=""
SET ZTSAVE("DIVDA(")=""
SET ZTIO=PSXLAP
+1 SET ZTRTN="START^PSXRACT"
+2 SET ZTDESC="CMOP Activity Report"
+3 DO ^%ZTLOAD
Q1 if $DATA(ZTSK)
WRITE !!,"Report Queued to Print!!"
+1 KILL DIR,PSXB,PSXE,Y
+2 QUIT
ST0 USE IO
+1 ;Called by taskman to print the CMOP Activity Report
START if $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 SET LINE="W ! F I=1:1:80 W ""="""
DIVISION ;
+1 SET DIVDA=0
FOR
SET DIVDA=$ORDER(DIVDA(DIVDA))
if DIVDA'>0
QUIT
DO ONEDIV
+2 DO GRNDSUM
+3 GOTO EXIT
+4 ;
+5 QUIT
ONEDIV ;
+1 SET LINE="W ! F I=1:1:80 W ""="""
SET CT=0
+2 SET Y=PSXB
XECUTE ^DD("DD")
SET PSXBE=Y
+3 SET Y=PSXE
XECUTE ^DD("DD")
SET PSXEE=Y
+4 SET PSXE1=PSXE+.99999
SET PSXD=PSXB-.00001
+5 DO TITLE
BATCH FOR
SET PSXD=$ORDER(^PSX(550.2,"D",PSXD))
if (+PSXD'>0)!(+PSXD>PSXE1)
QUIT
Begin DoDot:1
+1 FOR P5502=0:0
SET P5502=$ORDER(^PSX(550.2,"D",PSXD,P5502))
if 'P5502
QUIT
Begin DoDot:2
+2 SET BATCH=+$PIECE($GET(^PSX(550.2,P5502,0)),"^")
if $GET(BATCH)']""
QUIT
+3 SET DIV=$PIECE($GET(^PSX(550.2,P5502,0)),"^",3)
SET DIV=$PIECE($GET(^PS(59,DIV,0)),"^")
+4 IF '$DATA(DIVNM(DIV))
QUIT
+5 IF DIV'=DIVDA(DIVDA)
QUIT
+6 SET NODE=$GET(^PSX(550.2,P5502,1))
if $GET(NODE)']""
QUIT
+7 SET ORDS=$PIECE($GET(NODE),"^",7)
SET TORDS=$GET(TORDS)+ORDS
SET RTRN=$PIECE(NODE,"^",2)
+8 SET TORDS(DIV)=$GET(TORDS(DIV))+ORDS
+9 SET RXS=$PIECE($GET(NODE),"^",8)
SET TRXS=$GET(TRXS)+RXS
+10 SET TRXS(DIV)=$GET(TRXS(DIV))+RXS
+11 FOR PSXR=0:0
SET PSXR=$ORDER(^PSRX("AS",PSXD,PSXR))
if 'PSXR
QUIT
Begin DoDot:3
+12 SET PSXF=""
FOR
SET PSXF=$ORDER(^PSRX("AS",PSXD,PSXR,PSXF))
if ($GET(PSXF)']"")
QUIT
DO RX
End DoDot:3
+13 DO PRINT
if $GET(PSXFLAG)=1
QUIT
End DoDot:2
if $GET(PSXFLAG)=1
QUIT
End DoDot:1
if $GET(PSXFLAG)=1
QUIT
+14 XECUTE LINE
+15 SET DIV=DIVDA(DIVDA)
+16 WRITE !,?9,DIV,?35,$JUSTIFY($GET(TORDS(DIV)),7),?43,$JUSTIFY($GET(TRXS(DIV)),6),?53,$JUSTIFY($GET(PSXCRT(DIV)),7),?63,$JUSTIFY($GET(PSXNDT(DIV)),7),?73,$JUSTIFY($GET(PSXCUT(DIV)),5)
+17 QUIT
GRNDSUM ;
+1 SET DIVDA(0)=" Grand Total Summary"
SET DIVDA=0
+2 DO TITLE
+3 SET DIV=0
FOR
SET DIV=$ORDER(TORDS(DIV))
if DIV=""
QUIT
Begin DoDot:1
+4 WRITE !,?9,DIV,?35,$JUSTIFY($GET(TORDS(DIV)),7),?43,$JUSTIFY($GET(TRXS(DIV)),6),?53,$JUSTIFY($GET(PSXCRT(DIV)),7),?63,$JUSTIFY($GET(PSXNDT(DIV)),7),?73,$JUSTIFY($GET(PSXCUT(DIV)),5)
End DoDot:1
+5 XECUTE LINE
+6 WRITE !!,"TOTAL",?35,$JUSTIFY($GET(TORDS),7),?43,$JUSTIFY($GET(TRXS),6),?53,$JUSTIFY($GET(PSXCRT),7),?63,$JUSTIFY($GET(PSXNDT),7),?73,$JUSTIFY($GET(PSXCUT),5)
END KILL DIR,DIRUT,PSXB,PSXE,ZZTODAY,PSXLAP,PSXE1,PSXOT,PSXD,P5502,BATCH
+1 KILL DIV,NODE,TORDS,TRXS,PSXR,PSXF,GT,PSXFLAG,ZNODE,ZFILL,PSXSTAT,PSXCR
+2 KILL PSX,PSXCRT,PSXCUT,PSXLINE,PSXNDT,PSXNOW,X,Y,%,RTRN
+3 QUIT
EXIT ;
+1 DO END
+2 KILL DIVDA,DIVNM,PSXB,PSXE,LINE,CT,I,PSXBE,PSXEE,ZZTOT,ZTSK
+3 DO ^%ZISC
+4 QUIT
RX ; COUNT RX DATA
+1 IF $DATA(^PSRX(PSXR,4,0))
FOR PSX=0:0
SET PSX=$ORDER(^PSRX(PSXR,4,PSX))
if 'PSX
QUIT
Begin DoDot:1
+2 SET ZNODE=$GET(^PSRX(PSXR,4,PSX,0))
SET ZFILL=$PIECE($GET(ZNODE),"^",3)
+3 IF $GET(ZFILL)'=PSXF
KILL ZFILL
QUIT
+4 IF +$GET(ZNODE)'=BATCH
QUIT
+5 SET PSXSTAT=$PIECE($GET(ZNODE),"^",4)
SET PSX(ZFILL)=PSXSTAT
+6 KILL ZNODE,ZFILL,PSXSTAT
End DoDot:1
+7 IF $GET(PSX(PSXF))=1
SET PSXCR=$GET(PSXCR)+1
SET PSXCRT=$GET(PSXCRT)+1
Begin DoDot:1
+8 SET PSXCRT(DIV)=$GET(PSXCRT(DIV))+1
End DoDot:1
QUIT
+9 IF $GET(PSX(PSXF))=3
SET PSXND=$GET(PSXND)+1
SET PSXNDT=$GET(PSXNDT)+1
Begin DoDot:1
+10 SET PSXNDT(DIV)=$GET(PSXNDT(DIV))+1
End DoDot:1
QUIT
+11 IF $GET(PSX(PSXF))=2
SET PSXRT=$GET(PSXRT)+1
if (RTRN)>0
SET COM="FILLED IN "_$GET(RTRN)
+12 SET PSXCU=$GET(PSXCU)+1
SET PSXCUT=$GET(PSXCUT)+1
+13 SET PSXCUT(DIV)=$GET(PSXCUT(DIV))+1
+14 if $GET(COM)'=""
SET PSXCU=""
+15 QUIT
TITLE IF IOST["C-"
WRITE @IOF
+1 SET Y=PSXB
XECUTE ^DD("DD")
SET PSXBP=Y
+2 SET Y=PSXE
XECUTE ^DD("DD")
SET PSXEP=Y
+3 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
SET PSXNOW=Y
+4 WRITE !,?30,"CMOP ACTIVITY REPORT"_$SELECT($GET(ZZTOT)=1:" SUMMARY",1:"")
+5 WRITE !,DIVDA(DIVDA)
+6 WRITE !,"For ",PSXBP," thru ",$PIECE(PSXEP,"@"),?40,"Printed: ",PSXNOW
+7 SET PSXLINE=6
+8 KILL PSXBP,PSXEP
+9 XECUTE LINE
AHEAD WRITE !,"TRANS #",?9,"DIVISION",?37,"ORDERS",?45,"RXS",?53,"RELEASED",?63,"NOT DISP",?73,"UNREL"
+1 XECUTE LINE
+2 QUIT
PRINT IF IOST["C-"
IF ($GET(PSXLINE)>20)
Begin DoDot:1
+1 SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $GET(Y)'=1
SET PSXFLAG=1
KILL Y
QUIT
+2 DO TITLE
End DoDot:1
if $GET(PSXFLAG)=1
QUIT
+3 IF IOST'["C-"
IF ($GET(PSXLINE)>60)
WRITE @IOF
DO TITLE
+4 ;S:$G(COM)="" PSXCU=""
+5 WRITE !,$JUSTIFY($GET(BATCH),6),?9,$SELECT($GET(COM)'="":$EXTRACT($GET(DIV),1,10)_" "_$GET(COM),1:$GET(DIV)),?35,$JUSTIFY($GET(ORDS),7),?43,$JUSTIFY($GET(RXS),6),?53,$JUSTIFY($GET(PSXCR),7),?63,$JUSTIFY($GET(PSXND),7),?73,$JUSTIFY($GET(PSXCU),5
)
+6 SET PSXLINE=$GET(PSXLINE)+1
+7 KILL BATCH,DIV,ORDS,RXS,PSXCR,PSXND,PSXCU,PSXRT,COM,COM1
+8 QUIT
SEL ;Select divisions
+1 ; returns arrays
+2 ; DIVNM("names of divisions")=selection number
+3 ; DIVDA("iens of divisions")=name of division
+4 ; for testing
+5 WRITE !!,"SELECTION OF DIVISION(S)",!
+6 SET DIV=""
KILL DIVNM,DIVDA,DIVX
+7 FOR I=1:1
SET DIV=$ORDER(^PS(59,"B",DIV))
if DIV=""
QUIT
SET DIVNM(I)=DIV
SET DIVNM(DIV)=I
SET DIVDA=$ORDER(^PS(59,"B",DIV,0))
SET DIVNM(I,"I")=DIVDA
+8 SET I=I-1
+9 KILL DIR
SET DIR(0)="S^A:ALL DIVISIONS;S:SELECT DIVISIONS"
+10 DO ^DIR
KILL DIR
if Y="A"
GOTO ALL
+11 if Y="S"
GOTO SELECT
+12 QUIT
SELECT ;
+1 FOR C=1:1:I
SET DIR("A",C)=C_" "_DIVNM(C)
+2 SET DIR(0)="LO^1:"_I
SET DIR("A")="Select Division(s) "
+3 DO ^DIR
+4 IF '+Y
KILL DIVNM
QUIT
+5 MERGE DIVX=DIVNM
KILL DIVNM
+6 FOR I=1:1
SET X=$PIECE(Y,",",I)
if 'X
QUIT
MERGE DIVNM(X)=DIVX(X)
SET DIVNM=DIVX(X)
SET DIVNM(DIVNM)=X
+7 KILL DIVX,DIR
ALL WRITE !!,"You have selected:",!
SET DIV=0
FOR
SET DIV=$ORDER(DIVNM(DIV))
if 'DIV
QUIT
WRITE !,DIV,?5,DIVNM(DIV)
+1 SET DIR(0)="Y"
SET DIR("A")="Is this corrrect ? "
SET DIR("B")="YES"
DO ^DIR
+2 KILL DIR
+3 IF Y
Begin DoDot:1
+4 KILL DIVDA
+5 SET DIV=0
FOR
SET DIV=$ORDER(DIVNM(DIV))
if 'DIV
QUIT
SET DA=DIVNM(DIV,"I")
SET DIVDA(DA)=DIVNM(DIV)
KILL DIVNM(DIV)
End DoDot:1
QUIT
+6 GOTO SEL
+7 ;
