BPHRCLAS ;GDIT/HS/BEE-IHS PERSONAL HEALTH RECORD Cache Class Compiler ; 22 Aug 2013 7:51 AM
;;2.1;IHS PERSONAL HEALTH RECORD;**1**;Apr 01, 2014;Build 23
;
;
Q
;
EN Q
;
; Main entry point - interactive
EXPORT ;
N CNT,ERR,EXEC,I,MASK,STREAM,XML,NAME,B64
K CLASSES
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 90670.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=90670.5,DLAYGO=90670.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^BPHRCLAS(REC,XML) Q:ERR
. I ERR D ERROR
. D POPULATE^BPHRCLAS(REC,"------------------------- SEGMENT END ------------------------")
S DIE="^BPHRCLS("
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(^BPHRCLS(REC)) Q
I $G(DT)'?7N.E S DT=$$DT^XLFDT
; Change the value of field RPMS STATUS in 90670.5 to "I"
K DA S DA=REC,DIE="^BPHRCLS(",DR="1.02////I" D ^DIE
;
; 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(^BPHRCLS(REC,10,I)) Q:'I S STR=^BPHRCLS(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="^BPHRCLS("_REC_",11,",DIC(0)="L",DLAYGO=1
. S DA(1)=REC
. S X=CLASS
. D ^DIC
; Change the value of the field RPMS STATUS in 90670.5 to "R"
; and populate RPMS DATE/TIME INSTALLED
S DIE="^BPHRCLS("
K DA S DA=REC
; Set Status to READY
W !,"Updating 90670.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="^BPHRCLS("_DA(1)_",10," ;XML Subfile
S DIC(0)="L",DLAYGO=1 ;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 90670.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="^BPHRCLS("
I '$G(REC) Q
I '$D(^BPHRCLS(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))
Q
BPHRCLAS ;GDIT/HS/BEE-IHS PERSONAL HEALTH RECORD Cache Class Compiler ; 22 Aug 2013 7:51 AM
+1 ;;2.1;IHS PERSONAL HEALTH RECORD;**1**;Apr 01, 2014;Build 23
+2 ;
+3 ;
+4 QUIT
+5 ;
EN QUIT
+1 ;
+2 ; Main entry point - interactive
EXPORT ;
+1 NEW CNT,ERR,EXEC,I,MASK,STREAM,XML,NAME,B64
+2 KILL CLASSES
+3 SET MASK=""
FOR
Begin DoDot:1
+4 NEW DIR,X,Y
+5 SET DIR(0)="F"
+6 SET DIR("A")="Class"
+7 DO ^DIR
+8 SET MASK=$SELECT(X="^":"",1:X)
+9 IF MASK=""
QUIT
+10 IF MASK'?1.E1".CLS"&(MASK'?1.E1".cls")
SET MASK=MASK_".CLS"
+11 SET CLASSES(MASK)=""
End DoDot:1
IF $GET(MASK)=""
QUIT
+12 ;
+13 IF '$DATA(CLASSES)
QUIT
+14 ; Create a new global-based character stream
EXPGO ;
+1 ; Create new record in 90670.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=90670.5
SET DLAYGO=90670.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^BPHRCLAS(REC,XML)
IF ERR
QUIT
+25 IF ERR
DO ERROR
+26 DO POPULATE^BPHRCLAS(REC,"------------------------- SEGMENT END ------------------------")
End DoDot:1
IF ERR
QUIT
+27 SET DIE="^BPHRCLS("
+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(^BPHRCLS(REC))
QUIT
+8 IF $GET(DT)'?7N.E
SET DT=$$DT^XLFDT
+9 ; Change the value of field RPMS STATUS in 90670.5 to "I"
+10 KILL DA
SET DA=REC
SET DIE="^BPHRCLS("
SET DR="1.02////I"
DO ^DIE
+11 ;
+12 ; Create a new global-based character stream
+13 SET EXEC="S STREAM=##class(%Stream.GlobalCharacter).%New()"
+14 XECUTE EXEC
+15 ;
+16 ; Copy the XML from the distribution global to a stream
+17 SET I=0
+18 FOR
Begin DoDot:1
+19 SET B64=""
+20 FOR
SET I=$ORDER(^BPHRCLS(REC,10,I))
IF 'I
QUIT
SET STR=^BPHRCLS(REC,10,I,0)
IF STR["SEGMENT END"
QUIT
SET B64=B64_STR_$CHAR(13,10)
+21 IF B64=""
QUIT
+22 SET EXEC="S COMP=$system.Encryption.Base64Decode(B64)"
XECUTE EXEC
+23 SET EXEC="S STRING=$system.Util.Decompress(COMP)"
XECUTE EXEC
+24 SET EXEC="D STREAM.Write(STRING)"
XECUTE EXEC
End DoDot:1
IF B64=""
QUIT
+25 ;
+26 ; First check that the received classes are OK. Pass "1" in the 5th parameter
+27 ; so that the import won't actualy happen. Then analyze the value of "ERR"
+28 SET EXEC="D $system.OBJ.LoadStream(STREAM,""ck/lock=0"",.ERR,.LOADED,1)"
+29 XECUTE EXEC
+30 ; Error processing after the dry run
+31 IF ERR
DO BGERROR
GOTO EXIT
+32 ;
+33 ; Actually load and compile the classes.
+34 ; "c" means "compile" and "k" means "keep source code"
+35 SET EXEC="D $system.OBJ.LoadStream(STREAM,""ck/lock=0"",.ERR,.LOADED)"
+36 XECUTE EXEC
+37 ; Error processing after the actual load
+38 IF ERR
DO BGERROR
GOTO EXIT
+39 ;
+40 SET CLASS=""
FOR
SET CLASS=$ORDER(LOADED(CLASS))
IF CLASS=""
QUIT
Begin DoDot:1
+41 SET DIC="^BPHRCLS("_REC_",11,"
SET DIC(0)="L"
SET DLAYGO=1
+42 SET DA(1)=REC
+43 SET X=CLASS
+44 DO ^DIC
End DoDot:1
+45 ; Change the value of the field RPMS STATUS in 90670.5 to "R"
+46 ; and populate RPMS DATE/TIME INSTALLED
+47 SET DIE="^BPHRCLS("
+48 KILL DA
SET DA=REC
+49 ; Set Status to READY
+50 WRITE !,"Updating 90670.5 Record"
+51 DO NOW^%DTC
+52 SET DR="1.02////C;1.03////"_%
+53 DO ^DIE
EXIT ;
+1 QUIT
+2 ;
POPULATE(REC,XML) ;
+1 SET DA(1)=REC
+2 ;XML Subfile
KILL DIC
SET DIC="^BPHRCLS("_DA(1)_",10,"
+3 ;LAYGO to the subfile
SET DIC(0)="L"
SET DLAYGO=1
+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 90670.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="^BPHRCLS("
+9 IF '$GET(REC)
QUIT
+10 IF '$DATA(^BPHRCLS(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 QUIT
