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

INHSYSE.m

Go to the documentation of this file. 
  1. INHSYSE ;JPD;3 Sep 96;Save single file entries 
  1.  ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
  1.  ;COPYRIGHT 1991-2000 SAIC
  1.  ;CHCS TOOLS_460; GEN 5; 14-APR-1997
  1.  ;COPYRIGHT 1996 SAIC
  1.  Q
  1. EN ;Entry point for single element mover
  1.  N INPOP,INRTN,INROU K ^UTILITY($J)
  1.  S INPOP=0
  1.  S INRTN=$$READ
  1.  Q:INRTN=""
  1.  D START^INHSYS09
  1.  Q:'$D(^UTILITY($J))
  1.  D RTNBFR(INRTN,.INROU)
  1.  D NTRNL^INHSYS04(.INROU,$E($O(INROU(""),-1),1,6)_"W")
  1.  Q
  1. RTNBFR(%TT,INROU) ;routine buffer/builder machine
  1.  ;input:
  1.  ;  %TT   --> (required) Routine name to store data in
  1.  ;output:
  1.  ;  INROU --> array of compiled routines in the IB* name-space.
  1.  ;            format: INROU(routine name)=""
  1.  ;local:
  1.  ;  %RTN  --> routine root name to build
  1.  ;  %NODE --> global node result of $Q
  1.  ;  %DATA --> string of data
  1.  ;  INMAX --> maximum allowable routine source size
  1.  ;  INOS  --> operating system ien
  1.  ;  INZI  --> code to insert line into the routine directory
  1.  ;  %ODD  --> odd numbered offset
  1.  ;  %EVEN --> even numbered offset
  1.  ;
  1.  N %CC,%LC,INMAX,INOS,INZI,%RTN,%NODE,%DATA,%T,%RTNBFR,%ODD,%EVEN,%RC
  1.  K ^UTILITY($J,0)
  1.  S INMAX=^DD("ROU"),INOS=^("OS"),INZI=^("OS",INOS,"ZS")
  1.  S %CC=INMAX*2,%LC=0,%RC="00",%NODE="^UTILITY($J)"
  1.  S %RTN="IB"_$E(%TT,1,4)
  1.  S %RTNBFR="^UTILITY(""""INHSYS"""","
  1.  F  S %NODE=$Q(@%NODE) Q:$QS(%NODE,1)'=$J  D
  1.  .S %DATA=@%NODE
  1.  .I %CC+$L(%DATA)+$L(%NODE)'<INMAX D NEWR^INHSYS04
  1.  .D LN^INHSYS04(" ;;"_%NODE,.%CC,.%LC)
  1.  .D LN^INHSYS04(" ;;"_%DATA,.%CC,.%LC)
  1.  I $O(^UTILITY($J,0,0)) D
  1.  .D LN^INHSYS04(" Q",.%CC,.%LC) S X=%RTN_$S($L(%RC)=1:"0"_%RC,1:%RC) X INZI W !,X_" filed." S INROU(X)=""
  1.  .K ^UTILITY($J,0)
  1.  K ^UTILITY($J)
  1.  Q
  1. READ(INX) ;read 4 characters
  1.  S INX=$G(INX)
  1.  I INX="" S INX="Enter last 4 character of sir for routine name: "
  1.  F  D  Q:'$$CHECK
  1.  .S INRTN=$$READ^%ZTF(1,4,INX,"",13)
  1.  Q INRTN
  1. CHECK() ;check validity of 4 characters
  1.  N INLN
  1.  I INRTN="^" S INRTN="" Q 0
  1.  Q:INRTN="" 0
  1.  S INLN=$L(INRTN)
  1.  I INLN,INLN<4 W !,"You must enter EXACTLY 4 characters",! Q 1
  1.  I $D(^INRHT("ID",INRTN)) D  Q 1
  1.  .W !,"The 4 characters you chose are the same as a unique ID"
  1.  .W !,"Choose different characters",!
  1.  I $F(INRTN," ") W !,"Name cannot have spaces",! Q 1
  1.  Q 0
  1. RESTORE(%DRVR) ;Restore data from any element
  1.  ;Loop through PASS1 and PASS2
  1.  N %PASS,%LFILES,AA,%SAV,DFN,INMSG
  1.  D ENV^UTIL,^%ZIST
  1.  S INREPRT=+$G(INREPRT)
  1.  K ^UTILITY($J),^UTILITY("INHSYS",$J),^UTILITY("INHSYSUT",$J)
  1.  D EN^@%DRVR
  1.  I $D(^UTILITY("INHSYS")) F %PASS=1:1:2 D INST(%DRVR,.%PASS,INREPRT,.INFLD,.INMSG)
  1.  I $D(INMSG) D COMP(.INMSG)
  1.  ;Clean up ^UTILITY/Remove IB routines
  1.  K ^UTILITY($J),^UTILITY("INHSYS",$J),^UTILITY("INHSYSUT",$J)
  1.  W !!,"File transfer completed."
  1.  Q
  1. INST(%DRVR,%PASS,INREPRT,INFLD,INMSG) ;installation utility entry pnt
  1.  ;input:
  1.  ; %DRVR - Internal installation driver routine
  1.  ; %PASS - 0 or null - display report only
  1.  ;         1 - save off old files - create required fields
  1.  ;         2 - populate rest of file
  1.  ; INREPRT - 0 or null - off 1 - on
  1.  ; INFLD - Array of 4012 Script Generator Field entries
  1.  ;Output:
  1.  ; INMSG - Array of GIS entries
  1.  ;local:
  1.  ; %LINE - file information stored in ";;" comment form
  1.  ; %FNUM - file number
  1.  ; %ROOT - global root
  1.  ;
  1.  N B,%FNUM,%FLDS,%ROOT,%OIEN,%XNODE,%UNQ,Y,DA,%FILES,AA,%SAV
  1.  N DIC,X,DLAYGO,QT,I,%RQ,%MSG,%MSG2,%OMT,%FILES,%DIC0,%GLB,INPOP,INFLD
  1.  D ENV^UTIL
  1.  S INREPRT=$G(INREPRT),%PASS=$G(%PASS),(%MSG,%MSG2)=0,INPOP=0,INCR=1
  1.  S INFLG=$G(INFLG)
  1.  I '%PASS D EN^@%DRVR
  1.  I INREPRT U IO D HEAD^INHSYSUT(%PASS)
  1.  S QT=$C(34)
  1.  S %FNUM="" F  S %FNUM=$O(^UTILITY("INHSYS",$J,%FNUM)) Q:%FNUM=""  D
  1.  .;get root name of file
  1.  .S %ROOT=$G(^DIC(%FNUM,0,"GL")),%DIC0="X"
  1.  .I %ROOT="" W !,"Note .. DD file "_%FNUM_" is missing." Q
  1.  .I %PASS S %DIC0="LX"
  1.  .;loop thru utility using cross reference to get ien
  1.  .S %OIEN="" F  S %OIEN=$O(^UTILITY("INHSYS",$J,%FNUM,%OIEN)) Q:'%OIEN  D
  1.  ..N DA,DINUM
  1.  ..S %XNODE=$G(^UTILITY("INHSYS",$J,%FNUM,%OIEN,0))
  1.  ..I %XNODE="" Q
  1.  ..S Y=0
  1.  ..;Universal Interface custom
  1.  ..I %FNUM=4001 S Y=$O(^INTHU("C",$P(%XNODE,U,5),""))
  1.  ..;not criteria file
  1.  ..I %FNUM'="4001.1",'Y S Y=$$DIC^INHSYS05(%ROOT,$P(%XNODE,U),%FNUM,%DIC0) D:Y<0 MSG^INHSYSUT(%XNODE,%FNUM,.%MSG,0,%PASS)
  1.  ..;Criteria file custom code
  1.  ..I %FNUM="4001.1" D
  1.  ...N INOPT
  1.  ...S INOPT("TYPE")="TEST"
  1.  ...S (DIPA("DA"),Y)=$$NEW^INHUTC1(.INOPT,"U")
  1.  ...I Y<0 W !,"ERROR - UNABLE TO CREATE NEW CRITERIA" Q
  1.  ..;patient file
  1.  ..I %FNUM=2,%PASS=1 S DFN=+Y
  1.  ..;Files that require message to recompile
  1.  ..I %FNUM=4012!(%FNUM=4010)!(%FNUM=4012.1)!(%FNUM=4011) S INMSG(%FNUM,+Y)=$P(Y,U,2)
  1.  ..I INREPRT,Y>0 D PG^INHSYSUT(%PASS) W !,%FNUM,?14,$P($G(^DIC(%FNUM,0)),U),?42
  1.  ..;Save ien Kill off node
  1.  ..I %PASS=1,+Y>0 D  I +Y<0 D MSG^INHSYSUT(%XNODE,%FNUM,.%MSG,0,%PASS) Q
  1.  ...S DINUM=+Y,DIK=%ROOT,DA=+Y D ^DIK
  1.  ...;create stub node
  1.  ...S Y=$$DIC^INHSYS05(%ROOT,$P(%XNODE,U),%FNUM,%DIC0,"","",.DINUM)
  1.  ..S DA=+Y
  1.  ..I INREPRT,Y>0 D
  1.  ...W:%PASS'=1 ?42,".01",?56
  1.  ...W:%PASS'=1 $P(Y,U,2)
  1.  ...W !,%ROOT_DA I '%PASS W !
  1.  ..I INREPRT,Y'>0,%PASS=1 W ?42,".01"
  1.  ..I '%PASS,Y>0 D CMP^INHSYS07(+Y,%ROOT,%FNUM,%OIEN,1)
  1.  ..I %PASS D STUFF^INHSYS05(Y,%FNUM,%ROOT,"^UTILITY(""INHSYS"","_$J_","_QT_%FNUM_QT_","_%OIEN_",",1,DA,%PASS,.%MSG2,INREPRT)
  1.  I INREPRT,%MSG2 D PG^INHSYSUT(%PASS) W !,"*** Denotes ommitted, and not filed in system."
  1.  I INREPRT D PG^INHSYSUT(%PASS) W !!,"Pass "_%PASS_" Done! "
  1.  I INREPRT,%PASS=1,$E(IOST)="C",INCR,$$CR^UTSRD(0,IOSL-1)
  1.  Q
  1.  ;
  1. PKG(CLASS,RTN) ;Create package of routines in VMS flat file
  1.  ;  Input:
  1.  ;    CLASS - name of flat file that stores saved routines
  1.  ;    RTN - Name of beginning routine name to store in sequence
  1.  ;          in the flat file.
  1.  N %RTN K ^UTILITY($J)
  1.  D ENV^UTIL
  1.  S %RTN=RTN
  1.  D ORDER^INHUT3("^ ","%RTN",RTN,"$E(%RTN,1,$L(RTN))'=RTN","S ^UTILITY($J,%RTN)=""""")
  1.  D SAVEROU^INZTTC(CLASS)
  1.  Q
  1. UPKG(FNAME) ;replace routine into environment from flat file
  1.  ; Input:
  1.  ;   FNAME - Flat file name. Should end with .TT extention
  1.  D FN^ZCMSLD1(FNAME,0)
  1.  Q
  1. COMP(INMSG) ;Compile Script Generator Messages
  1.  ; Input: INMSG - Array of Script Generator Fields and Segments
  1.  ;    format - INMSG(4010,ien)
  1.  ;             INMSG(4012,ien)
  1.  ;
  1.  N INFL,INIEN,INMS,Y,INGALL
  1.  ;get messages related to Script Data Types
  1.  I $D(INMSG(4012.1)) D GETMSGDT^INHSYSU1(.INMSG,.INMS)
  1.  ;loop through in order of most likely to occur
  1.  F INFL=4012,4010,4011 I $D(INMSG(INFL)) D
  1.  .S INIEN="" F  S INIEN=$O(INMSG(INFL,INIEN)) Q:INIEN=""  D
  1.  ..;Get Script Generator Messages related to field
  1.  ..I INFL=4012 D GETMSGF^INHSYSU1(INIEN,.INMS,.INMSG) Q
  1.  ..;Get Script Generator Messages related to segment
  1.  ..I INFL=4010 D GETMSGS^INHSYSU1(INIEN,.INMS,.INMSG) Q
  1.  ..;Get Script Generator Messages from saved message
  1.  ..I INFL=4011 S INMS(INIEN)=""
  1.  ;compile Script Generator Messages
  1.  S INMS="",INGALL=1 F  S (INMS,Y)=$O(INMS(INMS)) Q:'Y  D EN^INHSGZ
  1.  Q
  1. SV2FLT(INAME,INDONE) ;Save utility stuff to flat file
  1.  ; Input:
  1.  ;   INAME - Name of flat file
  1.  ; Output: INDONE 0 did not finish 1 finished
  1.  N %NODE,%DATA,$ET,INDATE
  1.  S INDONE=0
  1.  Q:'$D(^UTILITY($J))
  1.  S %NODE="^UTILITY($J)",$ZT="ERR^INHSYSE"
  1.  S INAME=$$OPENSEQ^%ZTFS1(INAME,"BW")
  1.  I INAME="" W !,"Unable to open file" Q
  1.  U INAME
  1.  S INDATE=$$CDATASC^%ZTFDT($H,2,1)
  1.  W $P(INDATE,"@")_"     "_$P(INDATE,"@",2),!,"Interactive Test Utility Save"
  1.  F  S %NODE=$Q(@%NODE) Q:$QS(%NODE,1)'=$J  D
  1.  .S %DATA=@%NODE
  1.  .W !,%NODE
  1.  .W !,%DATA
  1.  W !,"**END**",!,"**END**"
  1.  I $$CLOSESEQ^%ZTFS1(INAME)
  1.  S INDONE=1
  1.  Q
  1. RSFRFLT(INAME) ;Restore from flat file
  1.  ;Input: - INAME - Name of flat file to restore from
  1.  N X,N,%RTNBFR,%ODD,%EVEN,%DATIM,%HEAD,$ET
  1.  K ^UTILITY("INHSYS",$J)
  1.  S %RTNBFR="^UTILITY(""INHSYS"",",$ZE="",$ZT="ERR^INHSYSE"
  1.  S INAME=$$OPENSEQ^%ZTFS1(INAME,"RB")
  1.  I INAME="" W !,"Unable to open file" Q
  1.  U INAME
  1.  R %DATIM:0,%HEAD:0
  1.  I %HEAD="Interactive Test Utility Save" D
  1.  .F  R %ODD:0 Q:'$T  Q:%ODD="**END**"  D
  1.  ..R %EVEN:0 Q:'$T
  1.  ..Q:%EVEN="**END**"
  1.  ..S X=%RTNBFR_$J_","_$P(%ODD,",",2,99)
  1.  ..S @X=%EVEN
  1.  S X=$$CLOSESEQ^%ZTFS1(INAME)
  1.  Q
  1. ERR ;if error occurs on save or restore
  1.  S X=$$CLOSESEQ^%ZTFS1(INAME),$ZT=""
  1.  W !,"An error has ocurred"
  1.  Q