BSTSCLAS.m

BSTSCLAS ;GDIT/HS/BEE-Post Install ; 5 Nov 2012  12:51 PM

 ;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62

 ;

EN Q

 ;

 ; Main entry point - interactive

EXPORT ;

 N CNT,ERR,EXEC,I,MASK,STREAM,XML,NAME,B64

 K CLASSES

 W !,"Enter class(es) to distribute, one at a time.  Wildcards OK."

 W !,"E.g, PACKAGE.CLASS.G*.CLS.   Hit <ENTER> when finished"

 S MASK="" F  D  Q:$G(MASK)=""

 . NEW DIR,X,Y

 . S DIR(0)="F"

 . S DIR("A")="Class: "

 . D ^DIR

 . S MASK=$S(X="^":"",1:X)

 . Q:MASK=""

 . S:MASK'?1.E1".CLS"&(MASK'?1.E1".cls") MASK=MASK_".CLS"

 . S CLASSES(MASK)=""

 ;

 Q:'$D(CLASSES)

 ; Create a new global-based character stream

EXPGO ;

 ; Create new record in 9002318.5 with IEN of REC

 ; Populate Name (not sure what it should be), Date/Time, and set status to I

 K DO,DA S DIC=9002318.5,DLAYGO=9002318.5,DIC(0)="L",X=$S($G(NAME)'="":NAME,1:"New Record for "_$H)

 S DIC("DR")=".01////"_X_";1.02////I"

 ; Do we need date on the Export?

 ;Set DIC("DR")=DIC("DR")_";1.03////"_$G(DT)

 D ^DIC

 I Y=-1 S ERR=1,ERR(1)="Failed to create a record" D ERROR Q

 S REC=+Y

 ; populate the new record

 S ERR=0,U="^"

 S EXEC="SET STREAM=##class(%Stream.GlobalCharacter).%New()"

 X EXEC

 ; Export a list of classes/routines/etc to the stream as XML

 S EXEC="DO $system.OBJ.ExportToStream(.CLASSES,.STREAM,.qlist,.ERR)"

 X EXEC

 ; ADD ERROR LOG

 I ERR D ERROR Q

 F  S EXEC="S STR=STREAM.Read(1000000)" X EXEC Q:STR=""  D  Q:ERR

 . S EXEC="S COMP=$system.Util.Compress(STR)" X EXEC

 . S EXEC="S B64=$system.Encryption.Base64Encode(COMP)" X EXEC

 . I $L(B64)="" S ERR=1,ERR(1)="Failed to create encrypted stream" D ERROR Q

 . S B64=$TR(B64,$C(10))

 . F I=1:1 SET XML=$P(B64,$C(13),I) Q:XML=""  D POPULATE^BSTSCLAS(REC,XML) Q:ERR

 . I ERR D ERROR

 . D POPULATE^BSTSCLAS(REC,"------------------------- SEGMENT END ------------------------")

 S DIE="^BSTSCLS("

 K DA S DA=REC

 ; Set Status to READY

 S DR="1.02////R"

 D ^DIE

 W !,"Record ",REC," created"

 Q

 ;

IMPORT(REC,ERR) ;

 ; Returns ERR if there are any errors.

 NEW EXEC,I,STREAM,STRING,B64,COMP,LOADED

 NEW %,DIE,DA,CLASS,DIWF,DIWL,DIWR,DLAYGO,DR,ERRTEXT,ERRTXT

 NEW J,MASK,NAME,STR,X,Y

 S ERR=0

 I $G(REC)="" Q

 I '$D(^BSTSCLS(REC)) Q

 I $G(DT)'?7N.E S DT=$$DT^XLFDT

 ; Change the value of field RPMS STATUS in 9002318.5 to "I"

 K DA S DA=REC,DIE="^BSTSCLS(",DR="1.02////I" D ^DIE

 ; Erase old errors

 ;S IEN=0 F  S IEN=$O(^BJMDS(90607,1,2,IEN)) Q:'IEN  K DA S DA=IEN,DA(1)=1,DIK="^BJMDS(90607,1,2," D ^DIK

 ;

 ; Create a new global-based character stream

 SET EXEC="S STREAM=##class(%Stream.GlobalCharacter).%New()"

 X EXEC

 ;

 ; Copy the XML from the distribution global to a stream

 S I=0

 F  D  Q:B64=""

 . S B64=""

 . F  S I=$O(^BSTSCLS(REC,10,I)) Q:'I  S STR=^BSTSCLS(REC,10,I,0) Q:STR["SEGMENT END"  S B64=B64_STR_$C(13,10)

 . I B64="" Q

 . S EXEC="S COMP=$system.Encryption.Base64Decode(B64)" X EXEC

 . S EXEC="S STRING=$system.Util.Decompress(COMP)" X EXEC

 . S EXEC="D STREAM.Write(STRING)" X EXEC

 ;

 ; First check that the received classes are OK. Pass "1" in the 5th parameter

 ; so that the import won't actualy happen. Then analyze the value of "ERR"

 S EXEC="D $system.OBJ.LoadStream(STREAM,""ck/lock=0"",.ERR,.LOADED,1)"

 X EXEC

 ; Error processing after the dry run

 I ERR D BGERROR G EXIT

 ;

 ; Actually load and compile the classes.

 ; "c" means "compile" and "k" means "keep source code"

 S EXEC="D $system.OBJ.LoadStream(STREAM,""ck/lock=0"",.ERR,.LOADED)"

 X EXEC

 ; Error processing after the actual load

 I ERR D BGERROR G EXIT

 ;

 S CLASS="" F  S CLASS=$O(LOADED(CLASS)) Q:CLASS=""  D

 . S DIC="^BSTSCLS("_REC_",11,",DIC(0)="L",DLAYGO=9002318.511

 . S DA(1)=REC

 . S X=CLASS

 . D ^DIC

 ; Change the value of the field RPMS STATUS in 9002318.5 to "R"

 ; and populate RPMS DATE/TIME INSTALLED

 S DIE="^BSTSCLS("

 K DA S DA=REC

 ; Set Status to READY

 W !,"Updating 9002318.5 Record"

 D NOW^%DTC

 S DR="1.02////C;1.03////"_%

 D ^DIE

EXIT ;

 Q

 ;

POPULATE(REC,XML) ;

 S DA(1)=REC

 K DIC S DIC="^BSTSCLS("_DA(1)_",10," ;XML Subfile

 S DIC(0)="L",DLAYGO=9002318.51 ;LAYGO to the subfile

 S X=XML

 ; S X=$$ENCODE(XML)

 ; Add XML Data as the .01 field

 D FILE^DICN

 I Y=-1 S ERR="Failed to create XML subfield entry" Q

 Q

ERROR ;

 S ERRTEXT=""

 I $D(ERR)=1,ERR'=0 S ERRTXT=ERR

 I $D(ERR)>10 S I="",ERRTXT="" F  S I=$O(ERR(I)) Q:'I  S ERRTXT=ERRTXT_$G(ERR(I))_" "

 W !,!,ERRTXT

 Q

BGERROR ;

 ;W !,"Class import process errored out with error ",$G(ERR)

 ;W !,"Please contact IHS National."

 ; Change the value of the field RPMS STATUS in 9002318.5 to "E"

 ; S ERRTEXT=""

 I $D(ERR)=1 S I=ERR K ERR S ERR=1,ERR(1)=I

 I $D(ERR)>10 S I="" D

 . F  S I=$O(ERR(I)) Q:'I  S ERR(I)=$TR(ERR(I),$C(10,13),"  ")

 S DIE="^BSTSCLS("

 I '$G(REC) Q

 I '$D(^BSTSCLS(REC)) Q

 K DA S DA=REC

 ; Set Status to ERROR

 S DR="1.02////E"

 D ^DIE

 K ^UTILITY($J,"W")

 S DIWF="C80",DIWL=1,DIWR=80,I=""

 F  S I=$O(ERR(I)) Q:'I  S X=ERR(I) D ^DIWP

 S I="" K ERR1 S ERR1=0

 F  S I=$O(^UTILITY($J,"W",I)) Q:'I  S J="" F  S J=$O(^UTILITY($J,"W",I,J)) Q:'J  S ERR1=ERR1+1,ERR1(ERR1)=$G(^UTILITY($J,"W",I,J,0))

 ;D WP^DIE(90607,"1,",2,"","ERR1")

 Q

BSTSCLAS  ;GDIT/HS/BEE-Post Install ; 5 Nov 2012  12:51 PM

 +1       ;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62

 +2       ;

EN         QUIT 

 +1       ;

 +2       ; Main entry point - interactive

EXPORT    ;

 +1        NEW CNT,ERR,EXEC,I,MASK,STREAM,XML,NAME,B64

 +2        KILL CLASSES

 +3        WRITE !,"Enter class(es) to distribute, one at a time.  Wildcards OK."

 +4        WRITE !,"E.g, PACKAGE.CLASS.G*.CLS.   Hit <ENTER> when finished"

 +5        SET MASK=""

           FOR 

               Begin DoDot:1

 +6                NEW DIR,X,Y

 +7                SET DIR(0)="F"

 +8                SET DIR("A")="Class: "

 +9                DO ^DIR

 +10               SET MASK=$SELECT(X="^":"",1:X)

 +11               IF MASK=""

                       QUIT 

 +12               IF MASK'?1.E1".CLS"&(MASK'?1.E1".cls")

                       SET MASK=MASK_".CLS"

 +13               SET CLASSES(MASK)=""

               End DoDot:1

               IF $GET(MASK)=""

                   QUIT 

 +14      ;

 +15       IF '$DATA(CLASSES)

               QUIT 

 +16      ; Create a new global-based character stream

EXPGO     ;

 +1       ; Create new record in 9002318.5 with IEN of REC

 +2       ; Populate Name (not sure what it should be), Date/Time, and set status to I

 +3        KILL DO,DA

           SET DIC=9002318.5

           SET DLAYGO=9002318.5

           SET DIC(0)="L"

           SET X=$SELECT($GET(NAME)'="":NAME,1:"New Record for "_$HOROLOG)

 +4        SET DIC("DR")=".01////"_X_";1.02////I"

 +5       ; Do we need date on the Export?

 +6       ;Set DIC("DR")=DIC("DR")_";1.03////"_$G(DT)

 +7        DO ^DIC

 +8        IF Y=-1

               SET ERR=1

               SET ERR(1)="Failed to create a record"

               DO ERROR

               QUIT 

 +9        SET REC=+Y

 +10      ; populate the new record

 +11       SET ERR=0

           SET U="^"

 +12       SET EXEC="SET STREAM=##class(%Stream.GlobalCharacter).%New()"

 +13       XECUTE EXEC

 +14      ; Export a list of classes/routines/etc to the stream as XML

 +15       SET EXEC="DO $system.OBJ.ExportToStream(.CLASSES,.STREAM,.qlist,.ERR)"

 +16       XECUTE EXEC

 +17      ; ADD ERROR LOG

 +18       IF ERR

               DO ERROR

               QUIT 

 +19       FOR 

               SET EXEC="S STR=STREAM.Read(1000000)"

               XECUTE EXEC

               IF STR=""

                   QUIT 

               Begin DoDot:1

 +20               SET EXEC="S COMP=$system.Util.Compress(STR)"

                   XECUTE EXEC

 +21               SET EXEC="S B64=$system.Encryption.Base64Encode(COMP)"

                   XECUTE EXEC

 +22               IF $LENGTH(B64)=""

                       SET ERR=1

                       SET ERR(1)="Failed to create encrypted stream"

                       DO ERROR

                       QUIT 

 +23               SET B64=$TRANSLATE(B64,$CHAR(10))

 +24               FOR I=1:1

                       SET XML=$PIECE(B64,$CHAR(13),I)

                       IF XML=""

                           QUIT 

                       DO POPULATE^BSTSCLAS(REC,XML)

                       IF ERR

                           QUIT 

 +25               IF ERR

                       DO ERROR

 +26               DO POPULATE^BSTSCLAS(REC,"------------------------- SEGMENT END ------------------------")

               End DoDot:1

               IF ERR

                   QUIT 

 +27       SET DIE="^BSTSCLS("

 +28       KILL DA

           SET DA=REC

 +29      ; Set Status to READY

 +30       SET DR="1.02////R"

 +31       DO ^DIE

 +32       WRITE !,"Record ",REC," created"

 +33       QUIT 

 +34      ;

IMPORT(REC,ERR) ;

 +1       ; Returns ERR if there are any errors.

 +2        NEW EXEC,I,STREAM,STRING,B64,COMP,LOADED

 +3        NEW %,DIE,DA,CLASS,DIWF,DIWL,DIWR,DLAYGO,DR,ERRTEXT,ERRTXT

 +4        NEW J,MASK,NAME,STR,X,Y

 +5        SET ERR=0

 +6        IF $GET(REC)=""

               QUIT 

 +7        IF '$DATA(^BSTSCLS(REC))

               QUIT 

 +8        IF $GET(DT)'?7N.E

               SET DT=$$DT^XLFDT

 +9       ; Change the value of field RPMS STATUS in 9002318.5 to "I"

 +10       KILL DA

           SET DA=REC

           SET DIE="^BSTSCLS("

           SET DR="1.02////I"

           DO ^DIE

 +11      ; Erase old errors

 +12      ;S IEN=0 F  S IEN=$O(^BJMDS(90607,1,2,IEN)) Q:'IEN  K DA S DA=IEN,DA(1)=1,DIK="^BJMDS(90607,1,2," D ^DIK

 +13      ;

 +14      ; Create a new global-based character stream

 +15       SET EXEC="S STREAM=##class(%Stream.GlobalCharacter).%New()"

 +16       XECUTE EXEC

 +17      ;

 +18      ; Copy the XML from the distribution global to a stream

 +19       SET I=0

 +20       FOR 

               Begin DoDot:1

 +21               SET B64=""

 +22               FOR 

                       SET I=$ORDER(^BSTSCLS(REC,10,I))

                       IF 'I

                           QUIT 

                       SET STR=^BSTSCLS(REC,10,I,0)

                       IF STR["SEGMENT END"

                           QUIT 

                       SET B64=B64_STR_$CHAR(13,10)

 +23               IF B64=""

                       QUIT 

 +24               SET EXEC="S COMP=$system.Encryption.Base64Decode(B64)"

                   XECUTE EXEC

 +25               SET EXEC="S STRING=$system.Util.Decompress(COMP)"

                   XECUTE EXEC

 +26               SET EXEC="D STREAM.Write(STRING)"

                   XECUTE EXEC

               End DoDot:1

               IF B64=""

                   QUIT 

 +27      ;

 +28      ; First check that the received classes are OK. Pass "1" in the 5th parameter

 +29      ; so that the import won't actualy happen. Then analyze the value of "ERR"

 +30       SET EXEC="D $system.OBJ.LoadStream(STREAM,""ck/lock=0"",.ERR,.LOADED,1)"

 +31       XECUTE EXEC

 +32      ; Error processing after the dry run

 +33       IF ERR

               DO BGERROR

               GOTO EXIT

 +34      ;

 +35      ; Actually load and compile the classes.

 +36      ; "c" means "compile" and "k" means "keep source code"

 +37       SET EXEC="D $system.OBJ.LoadStream(STREAM,""ck/lock=0"",.ERR,.LOADED)"

 +38       XECUTE EXEC

 +39      ; Error processing after the actual load

 +40       IF ERR

               DO BGERROR

               GOTO EXIT

 +41      ;

 +42       SET CLASS=""

           FOR 

               SET CLASS=$ORDER(LOADED(CLASS))

               IF CLASS=""

                   QUIT 

               Begin DoDot:1

 +43               SET DIC="^BSTSCLS("_REC_",11,"

                   SET DIC(0)="L"

                   SET DLAYGO=9002318.511

 +44               SET DA(1)=REC

 +45               SET X=CLASS

 +46               DO ^DIC

               End DoDot:1

 +47      ; Change the value of the field RPMS STATUS in 9002318.5 to "R"

 +48      ; and populate RPMS DATE/TIME INSTALLED

 +49       SET DIE="^BSTSCLS("

 +50       KILL DA

           SET DA=REC

 +51      ; Set Status to READY

 +52       WRITE !,"Updating 9002318.5 Record"

 +53       DO NOW^%DTC

 +54       SET DR="1.02////C;1.03////"_%

 +55       DO ^DIE

EXIT      ;

 +1        QUIT 

 +2       ;

POPULATE(REC,XML) ;

 +1        SET DA(1)=REC

 +2       ;XML Subfile

           KILL DIC

           SET DIC="^BSTSCLS("_DA(1)_",10,"

 +3       ;LAYGO to the subfile

           SET DIC(0)="L"

           SET DLAYGO=9002318.51

 +4        SET X=XML

 +5       ; S X=$$ENCODE(XML)

 +6       ; Add XML Data as the .01 field

 +7        DO FILE^DICN

 +8        IF Y=-1

               SET ERR="Failed to create XML subfield entry"

               QUIT 

 +9        QUIT 

ERROR     ;

 +1        SET ERRTEXT=""

 +2        IF $DATA(ERR)=1

               IF ERR'=0

                   SET ERRTXT=ERR

 +3        IF $DATA(ERR)>10

               SET I=""

               SET ERRTXT=""

               FOR 

                   SET I=$ORDER(ERR(I))

                   IF 'I

                       QUIT 

                   SET ERRTXT=ERRTXT_$GET(ERR(I))_" "

 +4        WRITE !,!,ERRTXT

 +5        QUIT 

BGERROR   ;

 +1       ;W !,"Class import process errored out with error ",$G(ERR)

 +2       ;W !,"Please contact IHS National."

 +3       ; Change the value of the field RPMS STATUS in 9002318.5 to "E"

 +4       ; S ERRTEXT=""

 +5        IF $DATA(ERR)=1

               SET I=ERR

               KILL ERR

               SET ERR=1

               SET ERR(1)=I

 +6        IF $DATA(ERR)>10

               SET I=""

               Begin DoDot:1

 +7                FOR 

                       SET I=$ORDER(ERR(I))

                       IF 'I

                           QUIT 

                       SET ERR(I)=$TRANSLATE(ERR(I),$CHAR(10,13),"  ")

               End DoDot:1

 +8        SET DIE="^BSTSCLS("

 +9        IF '$GET(REC)

               QUIT 

 +10       IF '$DATA(^BSTSCLS(REC))

               QUIT 

 +11       KILL DA

           SET DA=REC

 +12      ; Set Status to ERROR

 +13       SET DR="1.02////E"

 +14       DO ^DIE

 +15       KILL ^UTILITY($JOB,"W")

 +16       SET DIWF="C80"

           SET DIWL=1

           SET DIWR=80

           SET I=""

 +17       FOR 

               SET I=$ORDER(ERR(I))

               IF 'I

                   QUIT 

               SET X=ERR(I)

               DO ^DIWP

 +18       SET I=""

           KILL ERR1

           SET ERR1=0

 +19       FOR 

               SET I=$ORDER(^UTILITY($JOB,"W",I))

               IF 'I

                   QUIT 

               SET J=""

               FOR 

                   SET J=$ORDER(^UTILITY($JOB,"W",I,J))

                   IF 'J

                       QUIT 

                   SET ERR1=ERR1+1

                   SET ERR1(ERR1)=$GET(^UTILITY($JOB,"W",I,J,0))

 +20      ;D WP^DIE(90607,"1,",2,"","ERR1")

 +21       QUIT