VALMW3 ; ALB/MJK - Create transport routines for LM;03:39 PM 16 Dec 1992
;;1;List Manager;;Aug 13, 1993
;
EN ; -- exporter main entry point
N VALMSYS,VALMNS,VALMROU,VALMAX
S U="^",DTIME=600 K ^UTILITY($J)
D HOME^%ZIS
W @IOF,!?20,"*** List Template Export Utility ***"
I '$$DUZ() G ENQ
S VALMSYS=$$OS() I VALMSYS="" G ENQ
S VALMNS=$$NS() I VALMNS="" G ENQ
S VALMROU=$$ROU(.VALMNS) I VALMROU="" G ENQ
S VALMAX=$$MAX() I 'VALMAX G ENQ
W !!!,">>> Exporting LIST TEMPLATES with namespace '"_VALMNS_"'."
D BLD,FILE(.VALMROU)
ENQ Q
;
;
DUZ() ; -- check duz and duz(0)
I $S('$D(DUZ(0)):1,DUZ(0)'="@":1,1:0) D
.W !,"PROGRAMMER ACCESS REQUIRED",!
.S Y=0
E S Y=1
Q Y
;
OS() ; -- get os #
I $D(^%ZOSF("OS"))#2 D
.S Y=+$P(^("OS"),"^",2)
E S Y=0
Q Y
;
NS() ; -- ask for namespace
NS1 S VALMNS=""
W !!,">>> Enter the Name of the Package (2-4 characters): "
R X:$S($D(DTIME):DTIME,1:60) G NSQ:"^"[X
I X'?1U1.NU!($L(X)>4) D NS^VALMW5 G NS1
S VALMNS="",DIC="^DIC(9.4,",DIC(0)="EZ",D="C" D IX^DIC
I Y>0 S SDPK=+Y,VALMNS=$P(Y(0),U,2)
S:Y<1!(VALMNS="") VALMNS=$$ADHOC(X)
NSQ Q VALMNS
;
ROU(VALMNS) ; -- ask for export routine name
N ROU,DIR,X,Q
ROU1 S VALMROU=""
W ! S:$G(VALMNS)]"" DIR("B")=VALMNS_"L"
S DIR("A")=">>> Enter Routine Name",DIR(0)="F^2:6^" D ^DIR K DIR
G ROUQ:"^"[Y S VALMROU=Y
W !!,"I am going to create a series of '",VALMROU,"*' routines."
I $D(^%ZOSF("TEST"))#2 X ^("TEST") I W *7,!,"but '"_VALMROU_"' is ALREADY ON FILE!" S Q=1
W !,"Is that OK" D YN^DICN
I %<0!(%=2) S:%=2 VALMROU="" G ROUQ
I '% D ROU^VALMW5 G ROU1
ROUQ Q VALMROU
;
MAX() ; -- ask for max size of routines
N Y
MAX1 S Y=""
W !!,">>> MAXIMUM ROUTINE SIZE(BYTES): ",^DD("ROU"),"// "
R Y:$S($D(DTIME):DTIME,1:60) I '$T G MAXQ
S:Y="" Y=^DD("ROU")
I Y[U S Y="" G MAXQ
I Y\1'=Y!(Y<2000)!(Y>9999) D MAX^VALMW5 G MAX
MAXQ Q Y
;
ADHOC(X) ; -- pick any namespace
L W !!,"Package "_X_" not found"
W !,"Please enter the package namespace you wish to export: "
R X:300
I '$T!(X="")!(X'?1A.E) S X="" G LQ
I $L(X)>4 W !,"Namespace too long" G L
LQ Q X
;
BLD ; -- build utility
N VALMLN,VALMX,VALMNAME,VALM,VALMGLB
S VALMLN=0,VALMX=VALMNS
F S VALMX=$O(^SD(409.61,"B",VALMX)) Q:VALMX=""!($E(VALMX,1,$L(VALMNS))'=VALMNS) S VALM=+$O(^(VALMX,0)) I $D(^SD(409.61,VALM,0)),$P(^(0),U,7) S VALMNAME=$P(^(0),U) D
.W !?5,"o ",VALMNAME
.D SET(" W !,""'"_VALMNAME_"' List Template...""")
.D SET(" S DA=$O(^SD(409.61,""B"","""_VALMNAME_""",0)),DIK=""^SD(409.61,"" D ^DIK:DA")
.D SET(" K DO,DD S DIC(0)=""L"",DIC=""^SD(409.61,"",X="""_VALMNAME_""" D FILE^DICN S VALM=+Y")
.D SET(" I VALM>0 D")
.;
.S VALMGLB="^SD(409.61,"_VALM_",",X=VALMGLB_"-1)"
.F S X=$Q(@X) Q:$E(X,1,$L(VALMGLB))'=VALMGLB D:X'[",""B""," SET(" .S ^SD(409.61,VALM,"_$P(X,VALMGLB,2,99)_"="""_$$QUOTE(@X)_"""")
.;
.D SET(" .S DA=VALM,DIK=""^SD(409.61,"" D IX1^DIK K DA,DIK")
.D SET(" .W ""Filed.""")
.D SET(" ;")
D SET(" K DIC,DIK,VALM,X,DA Q")
Q3 Q
;
SET(X) ; -- set line utility
S VALMLN=VALMLN+1,^UTILITY($J,VALMLN,0)=X W "."
Q
;
QUOTE(X) ; -- add double quotes
N P,L
S P=1,L=$L(X)
F S P=$F(X,"""",P) Q:'P!(P>(L+1)) S X=$E(X,1,P-1)_""""_$E(X,P,L),L=L+1,P=P+1
Q X
;
FILE(VALMROU) ; -- file routines
N %H,VALMDATE,VALMNUM,VALMLN
S %H=+$H D YX^%DTC
S VALMDATE=$E(Y,5,6)_"-"_$E(Y,1,3)_"-"_$E(Y,9,12)
S VALMNUM="",VALMLN=0
F D SAVE(.VALMROU,.VALMNUM,.VALMLN,.VALMDATE) Q:VALMLN="" S VALMNUM=VALMNUM+1
Q
;
SAVE(VALMROU,VALMNUM,VALMLN,VALMDATE) ; -- save to routine
N LINE,SIZE
K ^UTILITY($J,0) S ^(0,1)=VALMROU_VALMNUM_" ; List Template Exporter ; "_VALMDATE,^(1.1)=" ;; ;",SIZE=0
F LINE=2:1 S VALMLN=$O(^UTILITY($J,VALMLN)) Q:VALMLN="" S ^UTILITY($J,0,LINE)=^(VALMLN,0),SIZE=$L(^(LINE))+SIZE I $E(^(LINE),1,2)'=" .",SIZE+700>VALMAX Q
I VALMLN,$O(^UTILITY($J,VALMLN)) S ^UTILITY($J,0,LINE+1)=" G ^"_VALMROU_(VALMNUM+1)
S X=VALMROU_VALMNUM X ^DD("OS",VALMSYS,"ZS") W !,X_" has been filed..."
Q
;
VALMW3 ; ALB/MJK - Create transport routines for LM;03:39 PM 16 Dec 1992
+1 ;;1;List Manager;;Aug 13, 1993
+2 ;
EN ; -- exporter main entry point
+1 NEW VALMSYS,VALMNS,VALMROU,VALMAX
+2 SET U="^"
SET DTIME=600
KILL ^UTILITY($JOB)
+3 DO HOME^%ZIS
+4 WRITE @IOF,!?20,"*** List Template Export Utility ***"
+5 IF '$$DUZ()
GOTO ENQ
+6 SET VALMSYS=$$OS()
IF VALMSYS=""
GOTO ENQ
+7 SET VALMNS=$$NS()
IF VALMNS=""
GOTO ENQ
+8 SET VALMROU=$$ROU(.VALMNS)
IF VALMROU=""
GOTO ENQ
+9 SET VALMAX=$$MAX()
IF 'VALMAX
GOTO ENQ
+10 WRITE !!!,">>> Exporting LIST TEMPLATES with namespace '"_VALMNS_"'."
+11 DO BLD
DO FILE(.VALMROU)
ENQ QUIT
+1 ;
+2 ;
DUZ() ; -- check duz and duz(0)
+1 IF $SELECT('$DATA(DUZ(0)):1,DUZ(0)'="@":1,1:0)
Begin DoDot:1
+2 WRITE !,"PROGRAMMER ACCESS REQUIRED",!
+3 SET Y=0
End DoDot:1
+4 IF '$TEST
SET Y=1
+5 QUIT Y
+6 ;
OS() ; -- get os #
+1 IF $DATA(^%ZOSF("OS"))#2
Begin DoDot:1
+2 SET Y=+$PIECE(^("OS"),"^",2)
End DoDot:1
+3 IF '$TEST
SET Y=0
+4 QUIT Y
+5 ;
NS() ; -- ask for namespace
NS1 SET VALMNS=""
+1 WRITE !!,">>> Enter the Name of the Package (2-4 characters): "
+2 READ X:$SELECT($DATA(DTIME):DTIME,1:60)
IF "^"[X
GOTO NSQ
+3 IF X'?1U1.NU!($LENGTH(X)>4)
DO NS^VALMW5
GOTO NS1
+4 SET VALMNS=""
SET DIC="^DIC(9.4,"
SET DIC(0)="EZ"
SET D="C"
DO IX^DIC
+5 IF Y>0
SET SDPK=+Y
SET VALMNS=$PIECE(Y(0),U,2)
+6 IF Y<1!(VALMNS="")
SET VALMNS=$$ADHOC(X)
NSQ QUIT VALMNS
+1 ;
ROU(VALMNS) ; -- ask for export routine name
+1 NEW ROU,DIR,X,Q
ROU1 SET VALMROU=""
+1 WRITE !
IF $GET(VALMNS)]""
SET DIR("B")=VALMNS_"L"
+2 SET DIR("A")=">>> Enter Routine Name"
SET DIR(0)="F^2:6^"
DO ^DIR
KILL DIR
+3 IF "^"[Y
GOTO ROUQ
SET VALMROU=Y
+4 WRITE !!,"I am going to create a series of '",VALMROU,"*' routines."
+5 IF $DATA(^%ZOSF("TEST"))#2
XECUTE ^("TEST")
IF $TEST
WRITE *7,!,"but '"_VALMROU_"' is ALREADY ON FILE!"
SET Q=1
+6 WRITE !,"Is that OK"
DO YN^DICN
+7 IF %<0!(%=2)
IF %=2
SET VALMROU=""
GOTO ROUQ
+8 IF '%
DO ROU^VALMW5
GOTO ROU1
ROUQ QUIT VALMROU
+1 ;
MAX() ; -- ask for max size of routines
+1 NEW Y
MAX1 SET Y=""
+1 WRITE !!,">>> MAXIMUM ROUTINE SIZE(BYTES): ",^DD("ROU"),"// "
+2 READ Y:$SELECT($DATA(DTIME):DTIME,1:60)
IF '$TEST
GOTO MAXQ
+3 IF Y=""
SET Y=^DD("ROU")
+4 IF Y[U
SET Y=""
GOTO MAXQ
+5 IF Y\1'=Y!(Y<2000)!(Y>9999)
DO MAX^VALMW5
GOTO MAX
MAXQ QUIT Y
+1 ;
ADHOC(X) ; -- pick any namespace
L WRITE !!,"Package "_X_" not found"
+1 WRITE !,"Please enter the package namespace you wish to export: "
+2 READ X:300
+3 IF '$TEST!(X="")!(X'?1A.E)
SET X=""
GOTO LQ
+4 IF $LENGTH(X)>4
WRITE !,"Namespace too long"
GOTO L
LQ QUIT X
+1 ;
BLD ; -- build utility
+1 NEW VALMLN,VALMX,VALMNAME,VALM,VALMGLB
+2 SET VALMLN=0
SET VALMX=VALMNS
+3 FOR
SET VALMX=$ORDER(^SD(409.61,"B",VALMX))
IF VALMX=""!($EXTRACT(VALMX,1,$LENGTH(VALMNS))'=VALMNS)
QUIT
SET VALM=+$ORDER(^(VALMX,0))
IF $DATA(^SD(409.61,VALM,0))
IF $PIECE(^(0),U,7)
SET VALMNAME=$PIECE(^(0),U)
Begin DoDot:1
+4 WRITE !?5,"o ",VALMNAME
+5 DO SET(" W !,""'"_VALMNAME_"' List Template...""")
+6 DO SET(" S DA=$O(^SD(409.61,""B"","""_VALMNAME_""",0)),DIK=""^SD(409.61,"" D ^DIK:DA")
+7 DO SET(" K DO,DD S DIC(0)=""L"",DIC=""^SD(409.61,"",X="""_VALMNAME_""" D FILE^DICN S VALM=+Y")
+8 DO SET(" I VALM>0 D")
+9 ;
+10 SET VALMGLB="^SD(409.61,"_VALM_","
SET X=VALMGLB_"-1)"
+11 FOR
SET X=$QUERY(@X)
IF $EXTRACT(X,1,$LENGTH(VALMGLB))'=VALMGLB
QUIT
IF X'[",""B"","
DO SET(" .S ^SD(409.61,VALM,"_$PIECE(X,VALMGLB,2,99)_"="""_$$QUOTE(@X)_"""")
+12 ;
+13 DO SET(" .S DA=VALM,DIK=""^SD(409.61,"" D IX1^DIK K DA,DIK")
+14 DO SET(" .W ""Filed.""")
+15 DO SET(" ;")
End DoDot:1
+16 DO SET(" K DIC,DIK,VALM,X,DA Q")
Q3 QUIT
+1 ;
SET(X) ; -- set line utility
+1 SET VALMLN=VALMLN+1
SET ^UTILITY($JOB,VALMLN,0)=X
WRITE "."
+2 QUIT
+3 ;
QUOTE(X) ; -- add double quotes
+1 NEW P,L
+2 SET P=1
SET L=$LENGTH(X)
+3 FOR
SET P=$FIND(X,"""",P)
IF 'P!(P>(L+1))
QUIT
SET X=$EXTRACT(X,1,P-1)_""""_$EXTRACT(X,P,L)
SET L=L+1
SET P=P+1
+4 QUIT X
+5 ;
FILE(VALMROU) ; -- file routines
+1 NEW %H,VALMDATE,VALMNUM,VALMLN
+2 SET %H=+$HOROLOG
DO YX^%DTC
+3 SET VALMDATE=$EXTRACT(Y,5,6)_"-"_$EXTRACT(Y,1,3)_"-"_$EXTRACT(Y,9,12)
+4 SET VALMNUM=""
SET VALMLN=0
+5 FOR
DO SAVE(.VALMROU,.VALMNUM,.VALMLN,.VALMDATE)
IF VALMLN=""
QUIT
SET VALMNUM=VALMNUM+1
+6 QUIT
+7 ;
SAVE(VALMROU,VALMNUM,VALMLN,VALMDATE) ; -- save to routine
+1 NEW LINE,SIZE
+2 KILL ^UTILITY($JOB,0)
SET ^(0,1)=VALMROU_VALMNUM_" ; List Template Exporter ; "_VALMDATE
SET ^(1.1)=" ;; ;"
SET SIZE=0
+3 FOR LINE=2:1
SET VALMLN=$ORDER(^UTILITY($JOB,VALMLN))
IF VALMLN=""
QUIT
SET ^UTILITY($JOB,0,LINE)=^(VALMLN,0)
SET SIZE=$LENGTH(^(LINE))+SIZE
IF $EXTRACT(^(LINE),1,2)'=" ."
IF SIZE+700>VALMAX
QUIT
+4 IF VALMLN
IF $ORDER(^UTILITY($JOB,VALMLN))
SET ^UTILITY($JOB,0,LINE+1)=" G ^"_VALMROU_(VALMNUM+1)
+5 SET X=VALMROU_VALMNUM
XECUTE ^DD("OS",VALMSYS,"ZS")
WRITE !,X_" has been filed..."
+6 QUIT
+7 ;
