- 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