XBGSAVE.m

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       ;