INZTTC ;WOM; 29 Nov 95 11:41; CMS Transaction Type Create
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;;
;Copyright 1995 SAIC
Q
CRE ; Create a TRANSACTION TYPE ELEMENT
; Also used by Replace, CIG, and RIG
; Input: %ACT = The menu number corresponding to
; the CMS function requested by user.
; Possible values shown at tag CRDEF
;==============================================
N I,INSELTT,DIC,FRNAME,RTN,PAUSE,Y,ZCMSERC,%,%U,%UTILITY,%RTN
S %=$ZSE("*.*"),$ZT="" I $P(%,":")=$P(%LIB,":")!($E(%,1,$F(%,"]")-1)=RLIB) D Q
.W !,B1,"This option is not available when your default directory is"
.W !,"the library directory!!",B0,! H 2
S PAUSE=1,%U=$P($ZC(%UCI),",",7),ZCMSERC=0
D VAR^DWUTL
S DIC="^INRHT(",DIC(0)="AEQZ",DIC("A")="Enter Transaction Type Name: "
D ^DIC I Y<1 W:0 !,B1,"Transaction Type not found",B0,! Q
I $P(Y(0),"^",4)="" W !,B1,"Invalid UNIQUE IDENTIFIER - Aborting!",B0,! Q
S INSELTT=1,(INSELTT(1),RTN)=+Y,FRNAME=$$TR(Y(0,0))
I %ACT=5!(%ACT=7),'$$CKRES(FRNAME) Q
;===============================================
D REMARK^ZCMS41
N %EN W ! S ZCMSGO=""
D ^ZCMSENV I ZCMSERR K ^UTILITY($J) Q
;UPDATE THE DEFAULT ENVIRONMENT
S DEFENV=$P(^ZCMSENV($J,"DEF"),"^",1),ULIB=$P(^ZCMSENV($J,"DEF"),"^",2)
S DEF=1,DEFLIB=ULIB,DEFDIR="DISK$CHCS_LIBRARY:["_DEFLIB_"]"
S ENVCNT=^ZCMSENV($J)-1
;==============================================
U 0 W !!,"Attempting to update the default library...",!
D CRDEF(FRNAME)
Q
CKRES(FRNAME) ;Check reservation
;FRNAME - Element name
N ZCMSRES,ZCMSRESU
D SHORES^ZCMSFNC(FRNAME)
I 'ZCMSRES W *7,!,FRNAME," not reserved!" Q 0
I ZCMSRES,(UNAM'=ZCMSRESU) W *7,!," Cannot replace ",FRNAME,"! This element is reserved by "_ZCMSRESU,! Q 0
Q 1
;===========================================
COMP() ; Compile IBxxxxnn and IBxxxxW programs for CREATE/CIG
; Returns 1 if successful, 0 if not
N INPOP S INPOP=0 D COMP^INHSYS(.INSELTT,0) Q:INPOP 0
D UTL I '$D(^UTILITY($J)) W !,B1,"No Transaction Type Created, aborting!",!,B0,! Q 0
Q 1
;==========================================
UTL ; Get all IBxxxxnn and IBxxxxW programs into ^UTILITY($J
S RTN="IB"_$$ID^INHSYS04(RTN),%RTN=RTN K ^UTILITY($J)
D ORDER^INHUT3("^ ","%RTN",RTN,"$E(%RTN,1,$L(RTN))'=RTN","S ^UTILITY($J,%RTN)=""""")
Q
;===========================================
CRDEF(FRNAME) ; Update Library
S FILE2=RLIB_FRNAME,KEEP=0
; VALUES FOR %ACT, calculated by program ZCMS
; 1= CREATE 2= FETCH 3= RESERVE
; 4= UNRESERVE 5= REPLACE 6= CIG
; 7= RIG 8= REFRESH
; Used for CREATE,REPLACE,CIG and RIG only
N FL S FL=1
;I %ACT=1!(%ACT=6)!(%ACT=7) D Q:'FL
D Q:'FL
.I $ZSE(FILE2)'="" U 0 W !,FRNAME," already exits in ",ULIB,! Q:%ACT=1!(%ACT=6)
.S FL=$$COMP() I FL D SAVEROU(FRNAME) D:%ACT'=7&(%ACT'=5) CREATE^ZCMS41(FRNAME,KEEP)
I %ACT'=5,%ACT'=6,%ACT'=7 Q
I %ACT'=6 D Q:'FL
.D SHORES^ZCMSFNC(FRNAME) I 'ZCMSRES&(%ACT=5!(%ACT=7)) W *7,!,FRNAME," not reserved!" S FL=0 Q
.I ZCMSRES,(UNAM'=ZCMSRESU) W *7,!," Cannot replace ",FRNAME,"! This element is reserved by "_ZCMSRESU,! S FL=0 Q
.D REPLACE^ZCMS41(FRNAME,KEEP)
I %ACT=6!(%ACT=7) W !,B1 S %DUMMY=$ZC(CMS,"INSERT GEN/ALWAYS "_FRNAME_" "_CNAME_" "_REMARK) W !,B0
Q
;===========================================
TR(X) ; Calculate Valid VMS filename for TRANSACTION TYPE by translating
; " " to "_", all other invalid characters to "-", and adding
; a ".TT" extension.
; Input should be the TRANSACTION TYPE NAME field
S:$L(X)>35 X=$$SUM(X)
Q $$TR^INHUT3(X)_".TT"
;==========================================
SUM(X) ; Calculate new VMS filename based on a check sum
; if length > 35 since VMS filenames can only be
; 39 characters (not including extention)
N I,SUM,A S SUM=0
F I=36:1 S A=$E(X,I) Q:A="" S SUM=SUM+$A($E(X,I))
Q $E(X,1,35)_$E(SUM,1,4)
;=====================================================
SAVEROU(FRNAME) ;SAVE MULTIPLE ROUTINES AS ONE ELEMENT/VMS FILE
; Programs/^UTILITY($J, created in function COMP
Q:'$D(^UTILITY($J)) N RNAME
S RNAME=$$OPENSEQ^%ZTFS1(FRNAME,"BW") U FRNAME
W "Saved by %RS from "_$ZU(0)_" on "_$P($ZH,",",3)
W !,"For CMS"
S RNAME="" F S RNAME=$O(^UTILITY($J,RNAME)) Q:RNAME="" W !,RNAME,! X "ZL @RNAME ZP"
W ! I $$CLOSESEQ^%ZTFS1(FRNAME)
U 0 W !
Q
INZTTC ;WOM; 29 Nov 95 11:41; CMS Transaction Type Create
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;;
+3 ;Copyright 1995 SAIC
+4 QUIT
CRE ; Create a TRANSACTION TYPE ELEMENT
+1 ; Also used by Replace, CIG, and RIG
+2 ; Input: %ACT = The menu number corresponding to
+3 ; the CMS function requested by user.
+4 ; Possible values shown at tag CRDEF
+5 ;==============================================
+6 NEW I,INSELTT,DIC,FRNAME,RTN,PAUSE,Y,ZCMSERC,%,%U,%UTILITY,%RTN
+7 SET %=$ZSE("*.*")
SET $ZT=""
IF $PIECE(%,":")=$PIECE(%LIB,":")!($EXTRACT(%,1,$FIND(%,"]")-1)=RLIB)
Begin DoDot:1
+8 WRITE !,B1,"This option is not available when your default directory is"
+9 WRITE !,"the library directory!!",B0,!
HANG 2
End DoDot:1
QUIT
+10 SET PAUSE=1
SET %U=$PIECE($ZC(%UCI),",",7)
SET ZCMSERC=0
+11 DO VAR^DWUTL
+12 SET DIC="^INRHT("
SET DIC(0)="AEQZ"
SET DIC("A")="Enter Transaction Type Name: "
+13 DO ^DIC
IF Y<1
IF 0
WRITE !,B1,"Transaction Type not found",B0,!
QUIT
+14 IF $PIECE(Y(0),"^",4)=""
WRITE !,B1,"Invalid UNIQUE IDENTIFIER - Aborting!",B0,!
QUIT
+15 SET INSELTT=1
SET (INSELTT(1),RTN)=+Y
SET FRNAME=$$TR(Y(0,0))
+16 IF %ACT=5!(%ACT=7)
IF '$$CKRES(FRNAME)
QUIT
+17 ;===============================================
+18 DO REMARK^ZCMS41
+19 NEW %EN
WRITE !
SET ZCMSGO=""
+20 DO ^ZCMSENV
IF ZCMSERR
KILL ^UTILITY($JOB)
QUIT
+21 ;UPDATE THE DEFAULT ENVIRONMENT
+22 SET DEFENV=$PIECE(^ZCMSENV($JOB,"DEF"),"^",1)
SET ULIB=$PIECE(^ZCMSENV($JOB,"DEF"),"^",2)
+23 SET DEF=1
SET DEFLIB=ULIB
SET DEFDIR="DISK$CHCS_LIBRARY:["_DEFLIB_"]"
+24 SET ENVCNT=^ZCMSENV($JOB)-1
+25 ;==============================================
+26 USE 0
WRITE !!,"Attempting to update the default library...",!
+27 DO CRDEF(FRNAME)
+28 QUIT
CKRES(FRNAME) ;Check reservation
+1 ;FRNAME - Element name
+2 NEW ZCMSRES,ZCMSRESU
+3 DO SHORES^ZCMSFNC(FRNAME)
+4 IF 'ZCMSRES
WRITE *7,!,FRNAME," not reserved!"
QUIT 0
+5 IF ZCMSRES
IF (UNAM'=ZCMSRESU)
WRITE *7,!," Cannot replace ",FRNAME,"! This element is reserved by "_ZCMSRESU,!
QUIT 0
+6 QUIT 1
+7 ;===========================================
COMP() ; Compile IBxxxxnn and IBxxxxW programs for CREATE/CIG
+1 ; Returns 1 if successful, 0 if not
+2 NEW INPOP
SET INPOP=0
DO COMP^INHSYS(.INSELTT,0)
IF INPOP
QUIT 0
+3 DO UTL
IF '$DATA(^UTILITY($JOB))
WRITE !,B1,"No Transaction Type Created, aborting!",!,B0,!
QUIT 0
+4 QUIT 1
+5 ;==========================================
UTL ; Get all IBxxxxnn and IBxxxxW programs into ^UTILITY($J
+1 SET RTN="IB"_$$ID^INHSYS04(RTN)
SET %RTN=RTN
KILL ^UTILITY($JOB)
+2 DO ORDER^INHUT3("^ ","%RTN",RTN,"$E(%RTN,1,$L(RTN))'=RTN","S ^UTILITY($J,%RTN)=""""")
+3 QUIT
+4 ;===========================================
CRDEF(FRNAME) ; Update Library
+1 SET FILE2=RLIB_FRNAME
SET KEEP=0
+2 ; VALUES FOR %ACT, calculated by program ZCMS
+3 ; 1= CREATE 2= FETCH 3= RESERVE
+4 ; 4= UNRESERVE 5= REPLACE 6= CIG
+5 ; 7= RIG 8= REFRESH
+6 ; Used for CREATE,REPLACE,CIG and RIG only
+7 NEW FL
SET FL=1
+8 ;I %ACT=1!(%ACT=6)!(%ACT=7) D Q:'FL
+9 Begin DoDot:1
+10 IF $ZSE(FILE2)'=""
USE 0
WRITE !,FRNAME," already exits in ",ULIB,!
IF %ACT=1!(%ACT=6)
QUIT
+11 SET FL=$$COMP()
IF FL
DO SAVEROU(FRNAME)
IF %ACT'=7&(%ACT'=5)
DO CREATE^ZCMS41(FRNAME,KEEP)
End DoDot:1
IF 'FL
QUIT
+12 IF %ACT'=5
IF %ACT'=6
IF %ACT'=7
QUIT
+13 IF %ACT'=6
Begin DoDot:1
+14 DO SHORES^ZCMSFNC(FRNAME)
IF 'ZCMSRES&(%ACT=5!(%ACT=7))
WRITE *7,!,FRNAME," not reserved!"
SET FL=0
QUIT
+15 IF ZCMSRES
IF (UNAM'=ZCMSRESU)
WRITE *7,!," Cannot replace ",FRNAME,"! This element is reserved by "_ZCMSRESU,!
SET FL=0
QUIT
+16 DO REPLACE^ZCMS41(FRNAME,KEEP)
End DoDot:1
IF 'FL
QUIT
+17 IF %ACT=6!(%ACT=7)
WRITE !,B1
SET %DUMMY=$ZC(CMS,"INSERT GEN/ALWAYS "_FRNAME_" "_CNAME_" "_REMARK)
WRITE !,B0
+18 QUIT
+19 ;===========================================
TR(X) ; Calculate Valid VMS filename for TRANSACTION TYPE by translating
+1 ; " " to "_", all other invalid characters to "-", and adding
+2 ; a ".TT" extension.
+3 ; Input should be the TRANSACTION TYPE NAME field
+4 IF $LENGTH(X)>35
SET X=$$SUM(X)
+5 QUIT $$TR^INHUT3(X)_".TT"
+6 ;==========================================
SUM(X) ; Calculate new VMS filename based on a check sum
+1 ; if length > 35 since VMS filenames can only be
+2 ; 39 characters (not including extention)
+3 NEW I,SUM,A
SET SUM=0
+4 FOR I=36:1
SET A=$EXTRACT(X,I)
IF A=""
QUIT
SET SUM=SUM+$ASCII($EXTRACT(X,I))
+5 QUIT $EXTRACT(X,1,35)_$EXTRACT(SUM,1,4)
+6 ;=====================================================
SAVEROU(FRNAME) ;SAVE MULTIPLE ROUTINES AS ONE ELEMENT/VMS FILE
+1 ; Programs/^UTILITY($J, created in function COMP
+2 IF '$DATA(^UTILITY($JOB))
QUIT
NEW RNAME
+3 SET RNAME=$$OPENSEQ^%ZTFS1(FRNAME,"BW")
USE FRNAME
+4 WRITE "Saved by %RS from "_$ZU(0)_" on "_$PIECE($ZH,",",3)
+5 WRITE !,"For CMS"
+6 SET RNAME=""
FOR
SET RNAME=$ORDER(^UTILITY($JOB,RNAME))
IF RNAME=""
QUIT
WRITE !,RNAME,!
XECUTE "ZL @RNAME ZP"
+7 WRITE !
IF $$CLOSESEQ^%ZTFS1(FRNAME)
+8 USE 0
WRITE !
+9 QUIT
