VAQPST31 ;JRP/ALB - UTILITIES FOR INSTALLING EXPORTED ROUTINES;24-AUG-93
;;1.5;PATIENT DATA EXCHANGE;**1**;NOV 17, 1993
;
EXIST(X) ;DETERMINE IF ROUTINE X EXISTS
;INPUT : X - Name of routine
;OUTPUT : 1 - Routine exists
; 0 - Routine doesn't exist
; "" - Error
;
;CHECK INPUT & EXISTANCE OF ^%ZOSF("TEST")
Q:($G(X)="") ""
Q:('$D(^%ZOSF("TEST"))) ""
;CHECK FOR EXISTANCE
X ^%ZOSF("TEST") Q $T
;
LOAD(X,ARRAY) ;LOAD ROUTINE X INTO ARRAY
;INPUT : X - Name of routine
; ARRAY - Array to copy into (full global reference)
;OUTPUT : None
;NOTES : ARRAY will be in the format
; ARRAY(Line_N,0)=Line number N of routine X
; : ARRAY will be killed before loading routine. If routine
; could not be loaded, ARRAY() will not exit.
;
;CHECK INPUT, KILL ARRAY, TEST FOR ^%ZOSF("LOAD")
Q:($G(ARRAY)="")
K @ARRAY
Q:($G(X)="")
Q:('$D(^%ZOSF("LOAD")))
;DECLARE VARIABLES
N XCNP,DIF,TMP,TMP1,TMP2
;SET REQUIRED VARIABLES
S TMP=$P(ARRAY,"(",1)
S TMP1=$P(ARRAY,"(",2)
S TMP2=$P(TMP1,")",1)
S:(TMP2="") DIF=TMP_"("
S:(TMP2'="") DIF=TMP_"("_TMP2_","
S XCNP=0
;LOAD ROUTINE
X ^%ZOSF("LOAD")
Q
;
COPY(OLDROU,NEWROU,XCN) ;COPY ROUTINE OLDROU TO ROUTINE NEWROU
;INPUT : OLDROU - Name of existing routine
; NEWROU - New name for routine
; XCN - Line in existing routine to begin copying from
; (defaults to line 1)
;OUTPUT : 0 - Success
; -1 - Error
;
;CHECK INPUT & EXISTANCE OF ^%ZOSF("SAVE")
Q:($G(OLDROU)="") -1
Q:($G(NEWROU)="") -1
S XCN=+$G(XCN)
Q:('$D(^%ZOSF("SAVE"))) -1
;CHECK FOR EXISTANCE OF OLDROU
Q:('$$EXIST(OLDROU)) -1
;DECLARE VARIABLES
N ROOT1,ROOT2,X,DIE
S ROOT1="^UTILITY(""VAQPST"","_$J_")"
S ROOT2="^UTILITY(""VAQPST"","_$J_","
K @ROOT1
;LOAD OLDROU
D LOAD(OLDROU,ROOT1)
Q:('$D(@ROOT1)) -1
;CALL TO ^%ZOSF("SAVE") START WITH LINE AFTER XCN. SUBTRACT
; ONE FROM THE VALUE PASSED TO MATCH STATED VALUE.
S XCN=XCN-1
;SAVE OLDROU AS NEWROU
S X=NEWROU
S DIE=ROOT2
X ^%ZOSF("SAVE")
K @ROOT1
;HAVE TO ASSUME THAT SAVE WAS SUCCESSFUL
Q 0
;
SECOND(ROU,STRIP) ;RETURN SECOND LINE OF ROUTINE ROU
;INPUT : ROU - Name of routine
; STRIP - Flad indicating of leading <TAB>; should be stripped
; If 1, strip <TAB>; (default)
; If 0, don't strip <TAB>;
;OUTPUT : Second line of ROU
; NULL returned on error
;
;CHECK INPUT
Q:($G(ROU)="") ""
Q:('$$EXIST(ROU)) ""
S:($G(STRIP)="") STRIP=1
;DECLARE VARIABLES
N ROOT,LINE2
S ROOT="^UTILITY(""VAQPST"","_$J_")"
;LOAD ROUTINE
D LOAD(ROU,ROOT)
Q:('$D(@ROOT)) ""
;GET SECOND LINE
S LINE2=$G(@ROOT@(2,0))
;STRIP LEADING <TAB>;
S:(STRIP) LINE2=$P(LINE2,";;",2,$L(LINE2,";;"))
K @ROOT
Q LINE2
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQPST31 2836 printed Dec 13, 2024@02:26:35 Page 2
VAQPST31 ;JRP/ALB - UTILITIES FOR INSTALLING EXPORTED ROUTINES;24-AUG-93
+1 ;;1.5;PATIENT DATA EXCHANGE;**1**;NOV 17, 1993
+2 ;
EXIST(X) ;DETERMINE IF ROUTINE X EXISTS
+1 ;INPUT : X - Name of routine
+2 ;OUTPUT : 1 - Routine exists
+3 ; 0 - Routine doesn't exist
+4 ; "" - Error
+5 ;
+6 ;CHECK INPUT & EXISTANCE OF ^%ZOSF("TEST")
+7 if ($GET(X)="")
QUIT ""
+8 if ('$DATA(^%ZOSF("TEST")))
QUIT ""
+9 ;CHECK FOR EXISTANCE
+10 XECUTE ^%ZOSF("TEST")
QUIT $TEST
+11 ;
LOAD(X,ARRAY) ;LOAD ROUTINE X INTO ARRAY
+1 ;INPUT : X - Name of routine
+2 ; ARRAY - Array to copy into (full global reference)
+3 ;OUTPUT : None
+4 ;NOTES : ARRAY will be in the format
+5 ; ARRAY(Line_N,0)=Line number N of routine X
+6 ; : ARRAY will be killed before loading routine. If routine
+7 ; could not be loaded, ARRAY() will not exit.
+8 ;
+9 ;CHECK INPUT, KILL ARRAY, TEST FOR ^%ZOSF("LOAD")
+10 if ($GET(ARRAY)="")
QUIT
+11 KILL @ARRAY
+12 if ($GET(X)="")
QUIT
+13 if ('$DATA(^%ZOSF("LOAD")))
QUIT
+14 ;DECLARE VARIABLES
+15 NEW XCNP,DIF,TMP,TMP1,TMP2
+16 ;SET REQUIRED VARIABLES
+17 SET TMP=$PIECE(ARRAY,"(",1)
+18 SET TMP1=$PIECE(ARRAY,"(",2)
+19 SET TMP2=$PIECE(TMP1,")",1)
+20 if (TMP2="")
SET DIF=TMP_"("
+21 if (TMP2'="")
SET DIF=TMP_"("_TMP2_","
+22 SET XCNP=0
+23 ;LOAD ROUTINE
+24 XECUTE ^%ZOSF("LOAD")
+25 QUIT
+26 ;
COPY(OLDROU,NEWROU,XCN) ;COPY ROUTINE OLDROU TO ROUTINE NEWROU
+1 ;INPUT : OLDROU - Name of existing routine
+2 ; NEWROU - New name for routine
+3 ; XCN - Line in existing routine to begin copying from
+4 ; (defaults to line 1)
+5 ;OUTPUT : 0 - Success
+6 ; -1 - Error
+7 ;
+8 ;CHECK INPUT & EXISTANCE OF ^%ZOSF("SAVE")
+9 if ($GET(OLDROU)="")
QUIT -1
+10 if ($GET(NEWROU)="")
QUIT -1
+11 SET XCN=+$GET(XCN)
+12 if ('$DATA(^%ZOSF("SAVE")))
QUIT -1
+13 ;CHECK FOR EXISTANCE OF OLDROU
+14 if ('$$EXIST(OLDROU))
QUIT -1
+15 ;DECLARE VARIABLES
+16 NEW ROOT1,ROOT2,X,DIE
+17 SET ROOT1="^UTILITY(""VAQPST"","_$JOB_")"
+18 SET ROOT2="^UTILITY(""VAQPST"","_$JOB_","
+19 KILL @ROOT1
+20 ;LOAD OLDROU
+21 DO LOAD(OLDROU,ROOT1)
+22 if ('$DATA(@ROOT1))
QUIT -1
+23 ;CALL TO ^%ZOSF("SAVE") START WITH LINE AFTER XCN. SUBTRACT
+24 ; ONE FROM THE VALUE PASSED TO MATCH STATED VALUE.
+25 SET XCN=XCN-1
+26 ;SAVE OLDROU AS NEWROU
+27 SET X=NEWROU
+28 SET DIE=ROOT2
+29 XECUTE ^%ZOSF("SAVE")
+30 KILL @ROOT1
+31 ;HAVE TO ASSUME THAT SAVE WAS SUCCESSFUL
+32 QUIT 0
+33 ;
SECOND(ROU,STRIP) ;RETURN SECOND LINE OF ROUTINE ROU
+1 ;INPUT : ROU - Name of routine
+2 ; STRIP - Flad indicating of leading <TAB>; should be stripped
+3 ; If 1, strip <TAB>; (default)
+4 ; If 0, don't strip <TAB>;
+5 ;OUTPUT : Second line of ROU
+6 ; NULL returned on error
+7 ;
+8 ;CHECK INPUT
+9 if ($GET(ROU)="")
QUIT ""
+10 if ('$$EXIST(ROU))
QUIT ""
+11 if ($GET(STRIP)="")
SET STRIP=1
+12 ;DECLARE VARIABLES
+13 NEW ROOT,LINE2
+14 SET ROOT="^UTILITY(""VAQPST"","_$JOB_")"
+15 ;LOAD ROUTINE
+16 DO LOAD(ROU,ROOT)
+17 if ('$DATA(@ROOT))
QUIT ""
+18 ;GET SECOND LINE
+19 SET LINE2=$GET(@ROOT@(2,0))
+20 ;STRIP LEADING <TAB>;
+21 if (STRIP)
SET LINE2=$PIECE(LINE2,";;",2,$LENGTH(LINE2,";;"))
+22 KILL @ROOT
+23 QUIT LINE2
