ORVOM ; slc/dcm - Generate ONITS- for OE/RR ;1/22/91 15:39
;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
I $S('$D(DUZ(0)):1,DUZ(0)'="@":1,1:0) W !,"PROGRAMMER ACCESS REQUIRED",! Q
R I $D(^%ZOSF("OS"))#2 S DISYS=+$P(^("OS"),"^",2)
Q:'$D(DISYS) R !!,"Enter the Name of the Package (2-4 characters): ",X:$S($D(DTIME):DTIME,1:60)
Q:"^"[X I X'?1U1.NU!($L(X)>4) D R^ORVOMH G R
S DIC="^DIC(9.4,",DIC(0)="E",D="C" D IX^DIC,Q^ORVOM0 S DPK=+Y G:Y<1 L
I $S('$D(^ORD(100.99,1,5,DPK,0)):1,'$L($P(^(0),"^",2))&('$O(^(1,0))):1,1:0) W !,"Nothing setup to export PROTOCOLS in the ORDER PARAMETERS file for this package" G Q
S DH=$S($D(^ORD(100.99,1,5,DPK,0)):$P(^(0),"^",2),1:"")
DH I $L(DH) W !,"Exporting PROTOCOLS with namespace "_DH S X=DH
R1 W !!,"I am going to create a routine called '",X,"ONIT'."
S U="^",%=0,%B="",DL=0,DIH="",DTL=X,DN=X_$E("ONI",1,5-$L(X))
S ^UTILITY($J)=DN,X=X_"ONIT"
I $D(^%ZOSF("TEST"))#2 X ^("TEST") I W $C(7),!,"but '"_X_"' is ALREADY ON FILE!" S Q=1
W !,"Is that OK" D YN^DICN G Q:%<0!(%=2) I '% D R1^ORVOMH G R1
R3 S %=1,Q=DPK,DPK(1)=""
S F(-1)=0
DD ;
D1 K ^UTILITY(U,$J),DR S DRN=DL,F=0,%=2 G Q:$D(F)+$D(Q)=2,S:Q<1
W !,"Moving "_$P(^DIC(9.4,DPK,0),U)_" Protocols into Onit's."
K ^UTILITY(U,$J,"PKG",DPK,"VERSION")
S D VER^ORVOM11 G Q:$D(DIRUT) G ^ORVOM0
;
Q G Q^ORVOM0
L W !!,"Package "_X_" not found",!,"Please enter the protocol namespace you wish to export: " R X:300 G Q:'$T!(X="")!(X'?1A.E)
I $L(X)>4 W !,"Namespace too long" G L
S DH=X G DH
Q
DOT ;;
W "." Q N DOT,I,J,X
I '$D(IOBS) D HOME^%ZIS
I '$L($G(IOBS)) W "." Q
S DOT=" .| o| O| ( )| < >| - -|"
F I=1:1:$L(DOT,"|") S X=$P(DOT,"|",I) W X H .2 F J=$L(X):-1:1 W @IOBS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORVOM 1732 printed Dec 13, 2024@02:34:52 Page 2
ORVOM ; slc/dcm - Generate ONITS- for OE/RR ;1/22/91 15:39
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
+2 IF $SELECT('$DATA(DUZ(0)):1,DUZ(0)'="@":1,1:0)
WRITE !,"PROGRAMMER ACCESS REQUIRED",!
QUIT
R IF $DATA(^%ZOSF("OS"))#2
SET DISYS=+$PIECE(^("OS"),"^",2)
+1 if '$DATA(DISYS)
QUIT
READ !!,"Enter the Name of the Package (2-4 characters): ",X:$SELECT($DATA(DTIME):DTIME,1:60)
+2 if "^"[X
QUIT
IF X'?1U1.NU!($LENGTH(X)>4)
DO R^ORVOMH
GOTO R
+3 SET DIC="^DIC(9.4,"
SET DIC(0)="E"
SET D="C"
DO IX^DIC
DO Q^ORVOM0
SET DPK=+Y
if Y<1
GOTO L
+4 IF $SELECT('$DATA(^ORD(100.99,1,5,DPK,0)):1,'$LENGTH($PIECE(^(0),"^",2))&('$ORDER(^(1,0))):1,1:0)
WRITE !,"Nothing setup to export PROTOCOLS in the ORDER PARAMETERS file for this package"
GOTO Q
+5 SET DH=$SELECT($DATA(^ORD(100.99,1,5,DPK,0)):$PIECE(^(0),"^",2),1:"")
DH IF $LENGTH(DH)
WRITE !,"Exporting PROTOCOLS with namespace "_DH
SET X=DH
R1 WRITE !!,"I am going to create a routine called '",X,"ONIT'."
+1 SET U="^"
SET %=0
SET %B=""
SET DL=0
SET DIH=""
SET DTL=X
SET DN=X_$EXTRACT("ONI",1,5-$LENGTH(X))
+2 SET ^UTILITY($JOB)=DN
SET X=X_"ONIT"
+3 IF $DATA(^%ZOSF("TEST"))#2
XECUTE ^("TEST")
IF $TEST
WRITE $CHAR(7),!,"but '"_X_"' is ALREADY ON FILE!"
SET Q=1
+4 WRITE !,"Is that OK"
DO YN^DICN
if %<0!(%=2)
GOTO Q
IF '%
DO R1^ORVOMH
GOTO R1
R3 SET %=1
SET Q=DPK
SET DPK(1)=""
+1 SET F(-1)=0
DD ;
D1 KILL ^UTILITY(U,$JOB),DR
SET DRN=DL
SET F=0
SET %=2
if $DATA(F)+$DATA(Q)=2
GOTO Q
if Q<1
GOTO S
+1 WRITE !,"Moving "_$PIECE(^DIC(9.4,DPK,0),U)_" Protocols into Onit's."
+2 KILL ^UTILITY(U,$JOB,"PKG",DPK,"VERSION")
S DO VER^ORVOM11
if $DATA(DIRUT)
GOTO Q
GOTO ^ORVOM0
+1 ;
Q GOTO Q^ORVOM0
L WRITE !!,"Package "_X_" not found",!,"Please enter the protocol namespace you wish to export: "
READ X:300
if '$TEST!(X="")!(X'?1A.E)
GOTO Q
+1 IF $LENGTH(X)>4
WRITE !,"Namespace too long"
GOTO L
+2 SET DH=X
GOTO DH
+3 QUIT
DOT ;;
+1 WRITE "."
QUIT
NEW DOT,I,J,X
+2 IF '$DATA(IOBS)
DO HOME^%ZIS
+3 IF '$LENGTH($GET(IOBS))
WRITE "."
QUIT
+4 SET DOT=" .| o| O| ( )| < >| - -|"
+5 FOR I=1:1:$LENGTH(DOT,"|")
SET X=$PIECE(DOT,"|",I)
WRITE X
HANG .2
FOR J=$LENGTH(X):-1:1
WRITE @IOBS
+6 QUIT
