XBGSAVE ; IHS/ADC/GTH - GENERIC GLOBAL SAVE FOR TRANSMISSION GLOBALS ; [ 07/21/2005 4:13 PM ]
;;3.0;IHS/VA UTILITIES;**9,10,11**;FEB 07, 1997
;XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods.
;
; XBGL = name of global (mandatory, all others optional)
;
; XBCON= if defined, stops if first-level subscript is non-cannonic
; XBDT = date of save, in FM format, default NOW
; XBE = ending first-level numeric subscript
; XBFLT= 1, saves as flat file
; XBFN = output file name, default "<ns><asufac>.<JulianDate>"
; XBF = beginning first-level numeric subscript, seed for $ORDER
; XBIO = output device number
; XBMED= media to which to save global (user asked, if not exist)
; XBNAR= description displayed to user, if user asks for help
; XBPAR= CR parameter (DSM only)
; XBQ = Y/N, to place file in uucp q, default "Y"
; XBQTO= 'sendto' destination, default AO sysid in RPMS SITE file
; XBTLE= comment for dump header (facility name is concatenated)
; XBUF = directory, default no longer provided - will kick out error
; if XBUF undefined and no directory found in files
; 9999999.39 or 8989.3
; XBS1 = zish send paramaters file entry
;
SETUP ;
I '$D(^%ZOSF("OS")) S XBFLG(1)="The ^%ZOSF(""OS"") node does not exist",XBFLG=-1 G EOJ
; I '(^%ZOSF("OS")["MSM"),'(^%ZOSF("OS")["DSM") S XBFLG(1)="Operating system is not 'MSM' or 'DSM'",XBFLG=-1 G EOJ ; IHS/SET/GTH XB*3*9 10/29/2002
I '(^%ZOSF("OS")["MSM"),'(^%ZOSF("OS")["OpenM") S XBFLG(1)="Operating system is not 'MSM' or 'Cache'",XBFLG=-1 G EOJ ; IHS/SET/GTH XB*3*9 10/29/2002
I '$G(DUZ(2)) S XBFLG(1)="Facility Number 'DUZ(2)' is not defined",XBFLG=-1 G EOJ
I '$D(XBGL) S XBFLG(1)="The variable 'XBGL' must contain the name of the global you wish to save." S XBFLG=-1 G EOJ
KILL XBFLG,XBGLL
S:'$D(DTIME) DTIME=300
CHECK ;
S X=XBGL
I $L(X,"(")>1,$P(X,"(",2)="" S X=$P(X,"(")
S:$E(X,$L(X))="," X=$E(X,1,($L(X)-1))
I $L(XBGL,"(")>1,$E(XBGL,$L(XBGL))'="," S XBGL=XBGL_","
I $L(X,"(")>1,$E(X,$L(X))'=")" S X=X_")"
S:$L(X,"(")=1 XBGL=X_"("
S XBGLL=U_X
CKGLOB ;
I '$D(@XBGLL) S XBFLG(1)="Transaction File does not exist",XBFLG=-1 G EOJ
;S:'$D(XBUF) XBUF="/usr/spool/uucppublic"
I $G(XBUF)="" S XBUF=$P($G(^AUTTSITE(1,1)),"^",2)
I XBUF="" S XBUF=$P($G(^XTV(8989.3,1,"DEV")),"^",1)
I XBUF="" D G EOJ
.S XBFLG(1)="Export Directory NOT Specified"
.S XBFLG=-1
I "/\"[$E(XBUF,$L(XBUF)) D
.S XBUF=$E(XBUF,1,($L(XBUF)-1))
I '$D(DT) D DT^DICRW
S X2=$E(DT,1,3)_"0101",X1=DT
D ^%DTC
S XBCARTNO=X+1,XBDT=$S($D(XBDT):$$FMTE^XLFDT(XBDT),1:$$HTE^XLFDT($H))
S:$E(XBGL)'=U XBGL=U_XBGL
S XBNAR=$G(XBNAR),XBTLE=$G(XBTLE)_" "_$P(^DIC(4,DUZ(2),0),U)
I $D(XBMED) S XBMED=$$UP^XLFSTR($E(XBMED))
S XBQ=$E($G(XBQ)_"Y")
I XBQ="Y" S XBQTO=$G(XBQTO) I XBQTO="" S XBQTO=$P(^AUTTSITE(1,0),U,14) I XBQTO="" S XBQ="N"
S XBF=$G(XBF),XBE=$G(XBE)
I XBF="" S XBF=""""""
I ^%ZOSF("OS")["DSM" G SETUPDSM
SETUPMSM ;
S:'$D(XBIO) XBIO=51
I $D(XBMED),'("CDFT"[XBMED) S XBFLG(1)="Media Type '"_XBMED_"' is incorrect",XBFLG=-1 G EOJ
D ^ZIBGSVEM
I $G(XBS1)'="" D
.S XBFLG=$$SENDTO1^ZISHMSMU(XBS1,XBPAFN)
.S XBFLG(1)=$P(XBFLG,"^",2)
.S XBFLG=+XBFLG
.Q:$D(ZTQUEUED)
.W:XBFLG=0 !!,"File was sent successfully"
.W:'(XBFLG=0) !!,"File was **NOT** sent successfully"
G EOJ
;
SETUPDSM ;
I '$D(XBIO) S XBIO=47
I $D(XBMED),'("CT"[XBMED) S XBFLG(1)="Media Type '"_XBMED_"' is incorrect",XBFLG=-1 G EOJ
D ^ZIBGSVED
EOJ ;
S:'$D(XBFLG) XBFLG=0
KILL %DT,X,XBCON,XBFN,XBGL,XBGLL,XBCARTNO,X1,X2,XBNAR,XBTLE,XBIO,XBPAR,XBDT,XBE,XBF,XBMED,XBUF,XBQ,XBQTO,XBFLT,XBSUFAC,Y
Q
;
XBGSAVE ; IHS/ADC/GTH - GENERIC GLOBAL SAVE FOR TRANSMISSION GLOBALS ; [ 07/21/2005 4:13 PM ]
+1 ;;3.0;IHS/VA UTILITIES;**9,10,11**;FEB 07, 1997
+2 ;XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods.
+3 ;
+4 ; XBGL = name of global (mandatory, all others optional)
+5 ;
+6 ; XBCON= if defined, stops if first-level subscript is non-cannonic
+7 ; XBDT = date of save, in FM format, default NOW
+8 ; XBE = ending first-level numeric subscript
+9 ; XBFLT= 1, saves as flat file
+10 ; XBFN = output file name, default "<ns><asufac>.<JulianDate>"
+11 ; XBF = beginning first-level numeric subscript, seed for $ORDER
+12 ; XBIO = output device number
+13 ; XBMED= media to which to save global (user asked, if not exist)
+14 ; XBNAR= description displayed to user, if user asks for help
+15 ; XBPAR= CR parameter (DSM only)
+16 ; XBQ = Y/N, to place file in uucp q, default "Y"
+17 ; XBQTO= 'sendto' destination, default AO sysid in RPMS SITE file
+18 ; XBTLE= comment for dump header (facility name is concatenated)
+19 ; XBUF = directory, default no longer provided - will kick out error
+20 ; if XBUF undefined and no directory found in files
+21 ; 9999999.39 or 8989.3
+22 ; XBS1 = zish send paramaters file entry
+23 ;
SETUP ;
+1 IF '$DATA(^%ZOSF("OS"))
SET XBFLG(1)="The ^%ZOSF(""OS"") node does not exist"
SET XBFLG=-1
GOTO EOJ
+2 ; I '(^%ZOSF("OS")["MSM"),'(^%ZOSF("OS")["DSM") S XBFLG(1)="Operating system is not 'MSM' or 'DSM'",XBFLG=-1 G EOJ ; IHS/SET/GTH XB*3*9 10/29/2002
+3 ; IHS/SET/GTH XB*3*9 10/29/2002
IF '(^%ZOSF("OS")["MSM")
IF '(^%ZOSF("OS")["OpenM")
SET XBFLG(1)="Operating system is not 'MSM' or 'Cache'"
SET XBFLG=-1
GOTO EOJ
+4 IF '$GET(DUZ(2))
SET XBFLG(1)="Facility Number 'DUZ(2)' is not defined"
SET XBFLG=-1
GOTO EOJ
+5 IF '$DATA(XBGL)
SET XBFLG(1)="The variable 'XBGL' must contain the name of the global you wish to save."
SET XBFLG=-1
GOTO EOJ
+6 KILL XBFLG,XBGLL
+7 IF '$DATA(DTIME)
SET DTIME=300
CHECK ;
+1 SET X=XBGL
+2 IF $LENGTH(X,"(")>1
IF $PIECE(X,"(",2)=""
SET X=$PIECE(X,"(")
+3 IF $EXTRACT(X,$LENGTH(X))=","
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+4 IF $LENGTH(XBGL,"(")>1
IF $EXTRACT(XBGL,$LENGTH(XBGL))'=","
SET XBGL=XBGL_","
+5 IF $LENGTH(X,"(")>1
IF $EXTRACT(X,$LENGTH(X))'=")"
SET X=X_")"
+6 IF $LENGTH(X,"(")=1
SET XBGL=X_"("
+7 SET XBGLL=U_X
CKGLOB ;
+1 IF '$DATA(@XBGLL)
SET XBFLG(1)="Transaction File does not exist"
SET XBFLG=-1
GOTO EOJ
+2 ;S:'$D(XBUF) XBUF="/usr/spool/uucppublic"
+3 IF $GET(XBUF)=""
SET XBUF=$PIECE($GET(^AUTTSITE(1,1)),"^",2)
+4 IF XBUF=""
SET XBUF=$PIECE($GET(^XTV(8989.3,1,"DEV")),"^",1)
+5 IF XBUF=""
Begin DoDot:1
+6 SET XBFLG(1)="Export Directory NOT Specified"
+7 SET XBFLG=-1
End DoDot:1
GOTO EOJ
+8 IF "/\"[$EXTRACT(XBUF,$LENGTH(XBUF))
Begin DoDot:1
+9 SET XBUF=$EXTRACT(XBUF,1,($LENGTH(XBUF)-1))
End DoDot:1
+10 IF '$DATA(DT)
DO DT^DICRW
+11 SET X2=$EXTRACT(DT,1,3)_"0101"
SET X1=DT
+12 DO ^%DTC
+13 SET XBCARTNO=X+1
SET XBDT=$SELECT($DATA(XBDT):$$FMTE^XLFDT(XBDT),1:$$HTE^XLFDT($HOROLOG))
+14 IF $EXTRACT(XBGL)'=U
SET XBGL=U_XBGL
+15 SET XBNAR=$GET(XBNAR)
SET XBTLE=$GET(XBTLE)_" "_$PIECE(^DIC(4,DUZ(2),0),U)
+16 IF $DATA(XBMED)
SET XBMED=$$UP^XLFSTR($EXTRACT(XBMED))
+17 SET XBQ=$EXTRACT($GET(XBQ)_"Y")
+18 IF XBQ="Y"
SET XBQTO=$GET(XBQTO)
IF XBQTO=""
SET XBQTO=$PIECE(^AUTTSITE(1,0),U,14)
IF XBQTO=""
SET XBQ="N"
+19 SET XBF=$GET(XBF)
SET XBE=$GET(XBE)
+20 IF XBF=""
SET XBF=""""""
+21 IF ^%ZOSF("OS")["DSM"
GOTO SETUPDSM
SETUPMSM ;
+1 IF '$DATA(XBIO)
SET XBIO=51
+2 IF $DATA(XBMED)
IF '("CDFT"[XBMED)
SET XBFLG(1)="Media Type '"_XBMED_"' is incorrect"
SET XBFLG=-1
GOTO EOJ
+3 DO ^ZIBGSVEM
+4 IF $GET(XBS1)'=""
Begin DoDot:1
+5 SET XBFLG=$$SENDTO1^ZISHMSMU(XBS1,XBPAFN)
+6 SET XBFLG(1)=$PIECE(XBFLG,"^",2)
+7 SET XBFLG=+XBFLG
+8 IF $DATA(ZTQUEUED)
QUIT
+9 IF XBFLG=0
WRITE !!,"File was sent successfully"
+10 IF '(XBFLG=0)
WRITE !!,"File was **NOT** sent successfully"
End DoDot:1
+11 GOTO EOJ
+12 ;
SETUPDSM ;
+1 IF '$DATA(XBIO)
SET XBIO=47
+2 IF $DATA(XBMED)
IF '("CT"[XBMED)
SET XBFLG(1)="Media Type '"_XBMED_"' is incorrect"
SET XBFLG=-1
GOTO EOJ
+3 DO ^ZIBGSVED
EOJ ;
+1 IF '$DATA(XBFLG)
SET XBFLG=0
+2 KILL %DT,X,XBCON,XBFN,XBGL,XBGLL,XBCARTNO,X1,X2,XBNAR,XBTLE,XBIO,XBPAR,XBDT,XBE,XBF,XBMED,XBUF,XBQ,XBQTO,XBFLT,XBSUFAC,Y
+3 QUIT
+4 ;
