| [613] | 1 | VAQPST31 ;JRP/ALB - UTILITIES FOR INSTALLING EXPORTED ROUTINES;24-AUG-93
|
|---|
| 2 | ;;1.5;PATIENT DATA EXCHANGE;**1**;NOV 17, 1993
|
|---|
| 3 | ;
|
|---|
| 4 | EXIST(X) ;DETERMINE IF ROUTINE X EXISTS
|
|---|
| 5 | ;INPUT : X - Name of routine
|
|---|
| 6 | ;OUTPUT : 1 - Routine exists
|
|---|
| 7 | ; 0 - Routine doesn't exist
|
|---|
| 8 | ; "" - Error
|
|---|
| 9 | ;
|
|---|
| 10 | ;CHECK INPUT & EXISTANCE OF ^%ZOSF("TEST")
|
|---|
| 11 | Q:($G(X)="") ""
|
|---|
| 12 | Q:('$D(^%ZOSF("TEST"))) ""
|
|---|
| 13 | ;CHECK FOR EXISTANCE
|
|---|
| 14 | X ^%ZOSF("TEST") Q $T
|
|---|
| 15 | ;
|
|---|
| 16 | LOAD(X,ARRAY) ;LOAD ROUTINE X INTO ARRAY
|
|---|
| 17 | ;INPUT : X - Name of routine
|
|---|
| 18 | ; ARRAY - Array to copy into (full global reference)
|
|---|
| 19 | ;OUTPUT : None
|
|---|
| 20 | ;NOTES : ARRAY will be in the format
|
|---|
| 21 | ; ARRAY(Line_N,0)=Line number N of routine X
|
|---|
| 22 | ; : ARRAY will be killed before loading routine. If routine
|
|---|
| 23 | ; could not be loaded, ARRAY() will not exit.
|
|---|
| 24 | ;
|
|---|
| 25 | ;CHECK INPUT, KILL ARRAY, TEST FOR ^%ZOSF("LOAD")
|
|---|
| 26 | Q:($G(ARRAY)="")
|
|---|
| 27 | K @ARRAY
|
|---|
| 28 | Q:($G(X)="")
|
|---|
| 29 | Q:('$D(^%ZOSF("LOAD")))
|
|---|
| 30 | ;DECLARE VARIABLES
|
|---|
| 31 | N XCNP,DIF,TMP,TMP1,TMP2
|
|---|
| 32 | ;SET REQUIRED VARIABLES
|
|---|
| 33 | S TMP=$P(ARRAY,"(",1)
|
|---|
| 34 | S TMP1=$P(ARRAY,"(",2)
|
|---|
| 35 | S TMP2=$P(TMP1,")",1)
|
|---|
| 36 | S:(TMP2="") DIF=TMP_"("
|
|---|
| 37 | S:(TMP2'="") DIF=TMP_"("_TMP2_","
|
|---|
| 38 | S XCNP=0
|
|---|
| 39 | ;LOAD ROUTINE
|
|---|
| 40 | X ^%ZOSF("LOAD")
|
|---|
| 41 | Q
|
|---|
| 42 | ;
|
|---|
| 43 | COPY(OLDROU,NEWROU,XCN) ;COPY ROUTINE OLDROU TO ROUTINE NEWROU
|
|---|
| 44 | ;INPUT : OLDROU - Name of existing routine
|
|---|
| 45 | ; NEWROU - New name for routine
|
|---|
| 46 | ; XCN - Line in existing routine to begin copying from
|
|---|
| 47 | ; (defaults to line 1)
|
|---|
| 48 | ;OUTPUT : 0 - Success
|
|---|
| 49 | ; -1 - Error
|
|---|
| 50 | ;
|
|---|
| 51 | ;CHECK INPUT & EXISTANCE OF ^%ZOSF("SAVE")
|
|---|
| 52 | Q:($G(OLDROU)="") -1
|
|---|
| 53 | Q:($G(NEWROU)="") -1
|
|---|
| 54 | S XCN=+$G(XCN)
|
|---|
| 55 | Q:('$D(^%ZOSF("SAVE"))) -1
|
|---|
| 56 | ;CHECK FOR EXISTANCE OF OLDROU
|
|---|
| 57 | Q:('$$EXIST(OLDROU)) -1
|
|---|
| 58 | ;DECLARE VARIABLES
|
|---|
| 59 | N ROOT1,ROOT2,X,DIE
|
|---|
| 60 | S ROOT1="^UTILITY(""VAQPST"","_$J_")"
|
|---|
| 61 | S ROOT2="^UTILITY(""VAQPST"","_$J_","
|
|---|
| 62 | K @ROOT1
|
|---|
| 63 | ;LOAD OLDROU
|
|---|
| 64 | D LOAD(OLDROU,ROOT1)
|
|---|
| 65 | Q:('$D(@ROOT1)) -1
|
|---|
| 66 | ;CALL TO ^%ZOSF("SAVE") START WITH LINE AFTER XCN. SUBTRACT
|
|---|
| 67 | ; ONE FROM THE VALUE PASSED TO MATCH STATED VALUE.
|
|---|
| 68 | S XCN=XCN-1
|
|---|
| 69 | ;SAVE OLDROU AS NEWROU
|
|---|
| 70 | S X=NEWROU
|
|---|
| 71 | S DIE=ROOT2
|
|---|
| 72 | X ^%ZOSF("SAVE")
|
|---|
| 73 | K @ROOT1
|
|---|
| 74 | ;HAVE TO ASSUME THAT SAVE WAS SUCCESSFUL
|
|---|
| 75 | Q 0
|
|---|
| 76 | ;
|
|---|
| 77 | SECOND(ROU,STRIP) ;RETURN SECOND LINE OF ROUTINE ROU
|
|---|
| 78 | ;INPUT : ROU - Name of routine
|
|---|
| 79 | ; STRIP - Flad indicating of leading <TAB>;; should be stripped
|
|---|
| 80 | ; If 1, strip <TAB>;; (default)
|
|---|
| 81 | ; If 0, don't strip <TAB>;;
|
|---|
| 82 | ;OUTPUT : Second line of ROU
|
|---|
| 83 | ; NULL returned on error
|
|---|
| 84 | ;
|
|---|
| 85 | ;CHECK INPUT
|
|---|
| 86 | Q:($G(ROU)="") ""
|
|---|
| 87 | Q:('$$EXIST(ROU)) ""
|
|---|
| 88 | S:($G(STRIP)="") STRIP=1
|
|---|
| 89 | ;DECLARE VARIABLES
|
|---|
| 90 | N ROOT,LINE2
|
|---|
| 91 | S ROOT="^UTILITY(""VAQPST"","_$J_")"
|
|---|
| 92 | ;LOAD ROUTINE
|
|---|
| 93 | D LOAD(ROU,ROOT)
|
|---|
| 94 | Q:('$D(@ROOT)) ""
|
|---|
| 95 | ;GET SECOND LINE
|
|---|
| 96 | S LINE2=$G(@ROOT@(2,0))
|
|---|
| 97 | ;STRIP LEADING <TAB>;;
|
|---|
| 98 | S:(STRIP) LINE2=$P(LINE2,";;",2,$L(LINE2,";;"))
|
|---|
| 99 | K @ROOT
|
|---|
| 100 | Q LINE2
|
|---|
