Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: INZTTC

INZTTC.m

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