ORVOM0 ; slc/dcm - Gathers parts to send ;1/23/91 06:47 ;
;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
S DIT=0,DL=DRN,DRN=1001,DHS=DH,DSEC=0
S ;
K ^UTILITY("DI",$J)
I ;
M S DIRS="K ^UTILITY(U,$J),^UTILITY(""DIK"",$J) "
W !,"MAXIMUM ROUTINE SIZE(BYTES): ",^DD("ROU"),"// "
R %:$S($D(DTIME):DTIME,1:60) E S DTOUT=1 G Q
S DIFRM=^DD("ROU")
I %]"" G Q:%[U S DIFRM=% I %\1'=%!(%<2000)!(%>9999) D M^ORVOMH G M
GO W !,"...OK, this may take a while, hold on please..."
S Y=101,Y(101)="",X="PRO" D ADD
K %,%1,%2,%3,Y,CTR,TOP G ^ORVOM1
;
ADD ;
Q:$D(^DIC(Y,0))[0!$D(DTL(Y)) Q:$P(^(0),X,1)]""!'$D(^(0,"GL")) S Y=^("GL")
I $L(DH) D:$O(@(Y_"""B"",DH,0)")) A F S DH=$O(@(Y_"""B"",DH)")) Q:DH=""!($E(DH,1,$L(DHS))'=DHS)!($E(DH,($L(DHS)+1))="Z") D A
S II=0 F S II=$O(^ORD(100.99,1,5,DPK,1,II)) Q:II<1 S D=+^(II,0) D:'$D(^UTILITY(U,$J,X,D)) A1 S III=0 F S III=$O(^ORD(100.99,1,5,DPK,1,II,1,III)) Q:III<1 S MEN=^(III,0) D MEN
S DH=DHS
Q
A ;
S D=$O(@(Y_"""B"",DH,0)"))
A1 S %X=Y_"D,",%Y="^UTILITY(U,$J,X,D,"
S Q(X)=0 D %XY^%RCR
S %=^UTILITY(U,$J,X,D,0),%1=+$P(%,U,12),%1=$S($D(^DIC(9.4,%1,0)):$P(^(0),U),1:""),$P(%,U,12)=%1,$P(%,U,5)=""
S ^UTILITY(U,$J,X,D,0)=% I $D(^(10,0)) S CTR=$P(^(0),"^",4),TOP=$P(^(0),"^",3) K ^("B"),^("C")
I $D(^UTILITY(U,$J,X,D,5)) S %=$P(^(5),"^"),%1=$P(%,";",2) I %,$D(@("^"_%1_+%_",0)")) S %=$P(^(0),"^"),$P(^UTILITY(U,$J,X,D,5),"^")=%_";"_%1
S %=0 F S %=$O(^ORD(101,D,10,%)) Q:'% I $D(^(%,0)) S %2=^(0) I $D(^ORD(101,+%2,0)) S %3=$P(^(0),"^"),%1=$E(%3,1,$L(DHS)) D A2
I $D(^UTILITY(U,$J,X,D,10,0)) S $P(^(0),"^",3,4)=CTR_"^"_TOP
I $D(^UTILITY(U,$J,X,D,3,0)) K ^("B") S I=0 F S I=$O(^UTILITY(U,$J,X,D,3,I)) Q:I<1 S KEY=^(I,0) K ^(0) I $D(^DIC(19.1,+KEY,0)) S KEY=$P(^(0),"^"),^UTILITY(U,$J,X,D,3,I,0)=KEY
Q
;
Q ;
K ^UTILITY($J),^(U,$J),DH,DHS,EH,ORVROM,DR,DD,DLAYGO,DIRS,DIMA,DMAX,DWLW,DREF,D1
K DIX,DIY,DO,DZ,DIK,DIFQ,DDF,DDT,NO,DIF,DIG,DIH,DIU,DIV,DIW
K %A,%B,%C,%V,%X,%Y,%Z,NM,DG,D0,DA,DIFRM,DL,D,E,F,R,III,KEY,TXT,DIC,DIE,DN,DPK,DQ,DRN
K DIFQR,DNAME,DSEC,DTL,DIFC,Q,DIDIU,DIFKEP,DIT,DILN2 Q
;
MEN ;add to menu
Q:'$D(^ORD(101,+MEN,0)) S OMEN=$P(^(0),"^"),IT=$O(^ORD(101,+MEN,10,"B",D,0)) Q:$D(^UTILITY(U,$J,X,D,"MEN",OMEN)) S ^UTILITY(U,$J,X,D,"MEN",OMEN)=$S(IT:^ORD(101,+MEN,10,IT,0),1:D)
I IT,$P(^ORD(101,+MEN,10,IT,0),"^",4) S X0=$P(^(0),"^",4),$P(^(0),"^",4)="" I $D(^ORD(101,X0,0)) S $P(^UTILITY(U,$J,X,D,"MEN",OMEN),"^",4)=$P(^(0),"^")
W !,"Sending "_$P(^ORD(101,D,0),"^")_" to go on "_$P(^ORD(101,+MEN,0),"^")_" menu."
Q
A2 I %1'=DHS,%3'?1"ORB".E K ^UTILITY(U,$J,X,D,10,%) S CTR=CTR-1,TOP=% Q
S ^UTILITY(U,$J,X,D,10,%,U)=%3
I $P(%2,"^",4),$D(^ORD(101,$P(%2,"^",4),0)) S $P(^UTILITY(U,$J,X,D,10,%,0),"^",4)=$P(^(0),"^")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORVOM0 2746 printed Oct 16, 2024@18:35:27 Page 2
ORVOM0 ; slc/dcm - Gathers parts to send ;1/23/91 06:47 ;
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
+2 SET DIT=0
SET DL=DRN
SET DRN=1001
SET DHS=DH
SET DSEC=0
S ;
+1 KILL ^UTILITY("DI",$JOB)
I ;
M SET DIRS="K ^UTILITY(U,$J),^UTILITY(""DIK"",$J) "
+1 WRITE !,"MAXIMUM ROUTINE SIZE(BYTES): ",^DD("ROU"),"// "
+2 READ %:$SELECT($DATA(DTIME):DTIME,1:60)
IF '$TEST
SET DTOUT=1
GOTO Q
+3 SET DIFRM=^DD("ROU")
+4 IF %]""
if %[U
GOTO Q
SET DIFRM=%
IF %\1'=%!(%<2000)!(%>9999)
DO M^ORVOMH
GOTO M
GO WRITE !,"...OK, this may take a while, hold on please..."
+1 SET Y=101
SET Y(101)=""
SET X="PRO"
DO ADD
+2 KILL %,%1,%2,%3,Y,CTR,TOP
GOTO ^ORVOM1
+3 ;
ADD ;
+1 if $DATA(^DIC(Y,0))[0!$DATA(DTL(Y))
QUIT
if $PIECE(^(0),X,1)]""!'$DATA(^(0,"GL"))
QUIT
SET Y=^("GL")
+2 IF $LENGTH(DH)
if $ORDER(@(Y_"""B"",DH,0)"))
DO A
FOR
SET DH=$ORDER(@(Y_"""B"",DH)"))
if DH=""!($EXTRACT(DH,1,$LENGTH(DHS))'=DHS)!($EXTRACT(DH,($LENGTH(DHS)+1))="Z")
QUIT
DO A
+3 SET II=0
FOR
SET II=$ORDER(^ORD(100.99,1,5,DPK,1,II))
if II<1
QUIT
SET D=+^(II,0)
if '$DATA(^UTILITY(U,$JOB,X,D))
DO A1
SET III=0
FOR
SET III=$ORDER(^ORD(100.99,1,5,DPK,1,II,1,III))
if III<1
QUIT
SET MEN=^(III,0)
DO MEN
+4 SET DH=DHS
+5 QUIT
A ;
+1 SET D=$ORDER(@(Y_"""B"",DH,0)"))
A1 SET %X=Y_"D,"
SET %Y="^UTILITY(U,$J,X,D,"
+1 SET Q(X)=0
DO %XY^%RCR
+2 SET %=^UTILITY(U,$JOB,X,D,0)
SET %1=+$PIECE(%,U,12)
SET %1=$SELECT($DATA(^DIC(9.4,%1,0)):$PIECE(^(0),U),1:"")
SET $PIECE(%,U,12)=%1
SET $PIECE(%,U,5)=""
+3 SET ^UTILITY(U,$JOB,X,D,0)=%
IF $DATA(^(10,0))
SET CTR=$PIECE(^(0),"^",4)
SET TOP=$PIECE(^(0),"^",3)
KILL ^("B"),^("C")
+4 IF $DATA(^UTILITY(U,$JOB,X,D,5))
SET %=$PIECE(^(5),"^")
SET %1=$PIECE(%,";",2)
IF %
IF $DATA(@("^"_%1_+%_",0)"))
SET %=$PIECE(^(0),"^")
SET $PIECE(^UTILITY(U,$JOB,X,D,5),"^")=%_";"_%1
+5 SET %=0
FOR
SET %=$ORDER(^ORD(101,D,10,%))
if '%
QUIT
IF $DATA(^(%,0))
SET %2=^(0)
IF $DATA(^ORD(101,+%2,0))
SET %3=$PIECE(^(0),"^")
SET %1=$EXTRACT(%3,1,$LENGTH(DHS))
DO A2
+6 IF $DATA(^UTILITY(U,$JOB,X,D,10,0))
SET $PIECE(^(0),"^",3,4)=CTR_"^"_TOP
+7 IF $DATA(^UTILITY(U,$JOB,X,D,3,0))
KILL ^("B")
SET I=0
FOR
SET I=$ORDER(^UTILITY(U,$JOB,X,D,3,I))
if I<1
QUIT
SET KEY=^(I,0)
KILL ^(0)
IF $DATA(^DIC(19.1,+KEY,0))
SET KEY=$PIECE(^(0),"^")
SET ^UTILITY(U,$JOB,X,D,3,I,0)=KEY
+8 QUIT
+9 ;
Q ;
+1 KILL ^UTILITY($JOB),^(U,$JOB),DH,DHS,EH,ORVROM,DR,DD,DLAYGO,DIRS,DIMA,DMAX,DWLW,DREF,D1
+2 KILL DIX,DIY,DO,DZ,DIK,DIFQ,DDF,DDT,NO,DIF,DIG,DIH,DIU,DIV,DIW
+3 KILL %A,%B,%C,%V,%X,%Y,%Z,NM,DG,D0,DA,DIFRM,DL,D,E,F,R,III,KEY,TXT,DIC,DIE,DN,DPK,DQ,DRN
+4 KILL DIFQR,DNAME,DSEC,DTL,DIFC,Q,DIDIU,DIFKEP,DIT,DILN2
QUIT
+5 ;
MEN ;add to menu
+1 if '$DATA(^ORD(101,+MEN,0))
QUIT
SET OMEN=$PIECE(^(0),"^")
SET IT=$ORDER(^ORD(101,+MEN,10,"B",D,0))
if $DATA(^UTILITY(U,$JOB,X,D,"MEN",OMEN))
QUIT
SET ^UTILITY(U,$JOB,X,D,"MEN",OMEN)=$SELECT(IT:^ORD(101,+MEN,10,IT,0),1:D)
+2 IF IT
IF $PIECE(^ORD(101,+MEN,10,IT,0),"^",4)
SET X0=$PIECE(^(0),"^",4)
SET $PIECE(^(0),"^",4)=""
IF $DATA(^ORD(101,X0,0))
SET $PIECE(^UTILITY(U,$JOB,X,D,"MEN",OMEN),"^",4)=$PIECE(^(0),"^")
+3 WRITE !,"Sending "_$PIECE(^ORD(101,D,0),"^")_" to go on "_$PIECE(^ORD(101,+MEN,0),"^")_" menu."
+4 QUIT
A2 IF %1'=DHS
IF %3'?1"ORB".E
KILL ^UTILITY(U,$JOB,X,D,10,%)
SET CTR=CTR-1
SET TOP=%
QUIT
+1 SET ^UTILITY(U,$JOB,X,D,10,%,U)=%3
+2 IF $PIECE(%2,"^",4)
IF $DATA(^ORD(101,$PIECE(%2,"^",4),0))
SET $PIECE(^UTILITY(U,$JOB,X,D,10,%,0),"^",4)=$PIECE(^(0),"^")
+3 QUIT
