PXRMEXU2 ; SLC/PKR/PJH - Reminder exchange repository utilities, #2.;07/02/2020
;;2.0;CLINICAL REMINDERS;**6,12,26,45,74**;Feb 04, 2005;Build 5
;=================================
EXCLASS(IEN) ;Return the class of the Exchange entry.
N ENV,TEMP
;If the Environment has been saved it will be on line 9.
S TEMP=^PXD(811.8,IEN,100,9,0)
S ENV=$S(TEMP["<ENV>":$$GETTAGV^PXRMEXU3(TEMP,"<ENV>",0),1:"")
;If ENV was not found on line 9 search for it.
I ENV="" D
. N IND
. S TEMP=""
. F IND=1:1 Q:(ENV'="")!(TEMP["</SOURCE>") D
.. S TEMP=^PXD(811.8,IEN,100,IND,0)
.. I TEMP["<ENV>" S ENV=$$GETTAGV^PXRMEXU3(TEMP,"<ENV>",0)
Q $S($P(ENV,U,1)="NATREM":1,$G(PXRMINST)=1:1,$D(XPDNM):1,1:0)
;
;=================================
FDA(IND,LC,TMPIND,FILENAME) ;Build the XML FDA output.
N FIELD,FILENUM,INDEX,INDEX0,JND,SIENS,WPC
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<FILEMAN_FDA>"
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<![CDATA["
;Get the file number.
S FILENUM=""
F S FILENUM=$O(^TMP(TMPIND,$J,IND,FILENAME,FILENUM)) Q:FILENUM="" D
.;Get the source IEN string.
. S SIENS=""
. F S SIENS=$O(^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS)) Q:SIENS="" D
.. S INDEX0=FILENUM_";"_SIENS
..;Get the field number and store the data.
.. S FIELD=""
.. F S FIELD=$O(^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS,FIELD)) Q:FIELD="" D
... S INDEX=INDEX0_";"_FIELD
...;If there is another index past the field then this is a
...;word-processing field.
... I $D(^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS,FIELD))=11 D
.... S WPC=$O(^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS,FIELD,""),-1)
.... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=INDEX_"~WP-start~"_WPC
.... F JND=1:1:WPC D
..... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS,FIELD,JND)
... E S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=INDEX_"~"_^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS,FIELD)
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="]]>"
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</FILEMAN_FDA>"
Q
;
;=================================
IENROOT(IND,LC,TMPIND,FILENAME) ;Build the XML IEN_ROOT output.
N INDEX,VALUE
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<IEN_ROOT>"
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<![CDATA["
S INDEX=0
F S INDEX=$O(^TMP(TMPIND,$J,IND,FILENAME,INDEX)) Q:INDEX="" D
. S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=INDEX_U_^TMP(TMPIND,$J,IND,FILENAME,INDEX)
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="]]>"
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</IEN_ROOT>"
Q
;
;=================================
MLWARN(FILENAME,PT01,IEN,LINE,MAXLEN) ;Issue a warning if the length of the
;line exceeds the maximum allowed value.
N DATA,INDICES,FIELD,LEN,TEXT
S LEN=$L(LINE)
S INDICES=$P(LINE,"~",1)
S FIELD=$P(INDICES,";",3)
S DATA=$P(LINE,"~",2)
S TEXT(1)="Warning the following line exceeds the VistA maximum allowed length of "_MAXLEN_"."
S TEXT(2)="Therefore this Exchange entry will not transport correctly."
S TEXT(3)="Line: "_LINE
S TEXT(4)="Its length is: "_LEN
S TEXT(5)="Component: "_FILENAME
S TEXT(6)="Name: "_PT01
S TEXT(7)="IEN: "_IEN
S TEXT(8)="Field number: "_FIELD
S TEXT(9)="Value: "_DATA
S TEXT(10)=""
D EN^DDIOL(.TEXT)
H 2
Q
;
;=================================
PATTR(IEN,ATTR) ;If the Reminder Exchange entry has the packing attribute
;ATTR return 1 otherwise return 0.
I $D(^PXD(811.8,IEN,140,"B",ATTR)) Q 1
Q 0
;
;=================================
STOREPR(SUCCESS,EFNAME,TMPIND,SELLIST) ;^TMP(TMPIND,$J contains data to be
;stored in the repository. Routines will be found in
;^TMP(TMPIND,$J,"ROUTINE",ROUTINE NAME,n) where n is the line number.
;File entries will be found in ^TMP(TMPIND,$J,N,FILENAME,indexes).
;This is output from the GETS^DIQ call. There are NUMF file entries.
;Format and store it as XML in the repository.
N DATE,DTEST,FDA,FILENAME,FILENUM,IEN
N IENROOT,IND,JND,LC,LINE,NCMPNT,NEWFILE,NUMF,PT01,RNAME
N SIENS,SOURCE,TEMP,VERSN
;If anything went wrong in the packing process then ^TMP(TMPIND,$J
;will not exist.
I '$D(^TMP(TMPIND,$J)) S SUCCESS=0 Q
;
K ^TMP($J,"CIND")
K ^TMP("PXRMEXRS",$J)
S ^TMP("PXRMEXRS",$J,1,0)="<?xml version=""1.0"" standalone=""yes""?>"
S ^TMP("PXRMEXRS",$J,2,0)="<REMINDER_EXCHANGE_FILE_ENTRY>"
S VERSN=$P(^PXRM(800,1,"VERSION"),U,1)
S ^TMP("PXRMEXRS",$J,3,0)="<PACKAGE_VERSION>"_VERSN_"</PACKAGE_VERSION>"
;The pointer to the index will be on line 4 so leave room.
S LC=4
;Save the source information.
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<SOURCE>"
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<NAME>"_$$TOXML^PXRMEXU3(^TMP(TMPIND,$J,"SRC","NAME"))_"</NAME>"
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<USER>"_$$TOXML^PXRMEXU3(^TMP(TMPIND,$J,"SRC","USER"))_"</USER>"
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<SITE>"_$$TOXML^PXRMEXU3(^TMP(TMPIND,$J,"SRC","SITE"))_"</SITE>"
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<ENV>"_^TMP(TMPIND,$J,"SRC","ENV")_"</ENV>"
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<DATE_PACKED>"_^TMP(TMPIND,$J,"SRC","DATE")_"</DATE_PACKED>"
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</SOURCE>"
;
;Save the description.
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<DESCRIPTION><![CDATA["
S IND=0
F S IND=$O(^TMP(TMPIND,$J,"DESC",1,IND)) Q:+IND=0 D
. S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=^TMP(TMPIND,$J,"DESC",1,IND,0)
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="]]></DESCRIPTION>"
;
;Save the keywords or phrases.
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<KEYWORDS>"
S IND=0
F S IND=$O(^TMP(TMPIND,$J,"KEYWORD",1,IND)) Q:+IND=0 D
. S TEMP=^TMP(TMPIND,$J,"KEYWORD",1,IND,0)
. I TEMP["," D
.. F JND=1:1:$L(TEMP,",") D
... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<KEYWORD>"_$$TOXML^PXRMEXU3($P(TEMP,",",JND))_"</KEYWORD>"
. E S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<KEYWORD>"_$$TOXML^PXRMEXU3(TEMP)_"</KEYWORD>"
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</KEYWORDS>"
;
;Save the packing attributes.
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<PACKING ATTRIBUTES><![CDATA["
S IND=0
F S IND=$O(^TMP(TMPIND,$J,"PATTR",IND)) Q:+IND=0 D
. S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<ATTRIBUTE>"_^TMP(TMPIND,$J,"PATTR",IND)_"</ATTRIBUTE>"
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="]]></PACKING ATTRIBUTES>"
;
S NCMPNT=0
;Do routines first.
S RNAME=""
F S RNAME=$O(^TMP(TMPIND,$J,"ROUTINE",RNAME)) Q:RNAME="" D
. S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<M_ROUTINE>"
. S NCMPNT=NCMPNT+1
. S ^TMP($J,"CIND",NCMPNT,"M_ROUTINE_START")=LC
. S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<ROUTINE_NAME>"_RNAME_"</ROUTINE_NAME>"
. S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<CHECKSUM>"_^TMP("PXRMEXCS",$J,"ROUTINE",RNAME)_"</CHECKSUM>"
. S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<CODE>"
. S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<![CDATA["
. S ^TMP($J,"CIND",NCMPNT,"ROUTINE_CODE_START")=LC+1
. S LINE=0
. F S LINE=$O(^TMP(TMPIND,$J,"ROUTINE",RNAME,LINE)) Q:LINE="" D
.. S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)=^TMP(TMPIND,$J,"ROUTINE",RNAME,LINE,0)
. S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="]]>"
. S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</CODE>"
. S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</M_ROUTINE>"
. S ^TMP($J,"CIND",NCMPNT,"ROUTINE_CODE_END")=LC-3
;
;Do file entries. For word processing fields the first line is
;file number;source ien string;field~WP-start~line count
;The next line count lines are the WP data.
S NUMF=+$G(^TMP(TMPIND,$J,"NUMF"))
S FILENAME=""
F IND=1:1:NUMF D
. F S FILENAME=$O(^TMP(TMPIND,$J,IND,FILENAME)) Q:FILENAME="" D
.. I FILENAME["IENROOT" S NEWFILE=0,IENROOT=1
.. E S NEWFILE=1,IENROOT=0
.. I NEWFILE D
... S FILENUM=$O(^TMP(TMPIND,$J,IND,FILENAME,""))
... S SIENS=$O(^TMP(TMPIND,$J,IND,FILENAME,FILENUM,""))
... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<FILEMAN_FILE>"
... S NCMPNT=NCMPNT+1
... S ^TMP($J,"CIND",NCMPNT,"FILE_START")=LC
... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<FILE_NAME>"_$$TOXML^PXRMEXU3(FILENAME)_"</FILE_NAME>"
... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<FILE_NUMBER>"_FILENUM_"</FILE_NUMBER>"
... S LC=LC+1,PT01=^TMP(TMPIND,$J,IND,FILENAME,FILENUM,SIENS,.01)
... S ^TMP("PXRMEXRS",$J,LC,0)="<POINT_01>"_$$TOXML^PXRMEXU3(PT01)_"</POINT_01>"
... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<INTERNAL_ENTRY_NUMBER>"_+SIENS_"</INTERNAL_ENTRY_NUMBER>"
... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<CHECKSUM>"_^TMP("PXRMEXCS",$J,IND,FILENAME)_"</CHECKSUM>"
... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<SELECTED>"_$S($D(SELLIST(FILENUM,"IEN",+SIENS)):"YES",1:"NO")_"</SELECTED>"
... S ^TMP($J,"CIND",NCMPNT,"FDA_START")=LC+3
... D FDA(IND,.LC,TMPIND,FILENAME)
... S ^TMP($J,"CIND",NCMPNT,"FDA_END")=LC-2
..;The ien root information always comes after the FDA.
.. I IENROOT D
... S ^TMP($J,"CIND",NCMPNT,"IEN_ROOT_START")=LC+3
... D IENROOT(IND,.LC,TMPIND,FILENAME)
... S ^TMP($J,"CIND",NCMPNT,"IEN_ROOT_END")=LC-2
. S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</FILEMAN_FILE>"
;Save the index.
S LC=LC+1,^TMP("PXRMEXRS",$J,4,0)="<INDEX_AT>"_LC_"</INDEX_AT>"
S ^TMP("PXRMEXRS",$J,LC,0)="<INDEX>"
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<NUMBER_OF_COMPONENTS>"_NCMPNT_"</NUMBER_OF_COMPONENTS>"
F IND=1:1:NCMPNT D
. S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<COMPONENT>"
. S JND=""
. F S JND=$O(^TMP($J,"CIND",IND,JND)) Q:JND="" D
.. S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<"_JND_">"_^TMP($J,"CIND",IND,JND)_"</"_JND_">"
. S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</COMPONENT>"
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</INDEX>"
S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="</REMINDER_EXCHANGE_FILE_ENTRY>"
;Establish the entry in the repository.
S SOURCE=^TMP(TMPIND,$J,"SRC","USER")_" at "_^TMP(TMPIND,$J,"SRC","SITE")
S DATE=^TMP(TMPIND,$J,"SRC","DATE")
S FDA(811.8,"+1,",.01)=EFNAME
S FDA(811.8,"+1,",.02)=SOURCE
S FDA(811.8,"+1,",.03)=DATE
D UPDATE^PXRMEXPU(.SUCCESS,.FDA,.IENROOT)
I SUCCESS D
. M ^PXD(811.8,IENROOT(1),100)=^TMP("PXRMEXRS",$J)
.;Set the 0 node.
. S ^PXD(811.8,IENROOT(1),100,0)=U_811.801_U_LC_U_LC
.;Create the description for this repository entry.
. N DESC,DESL,KEYWORD
. S DESL("SOURCE")=^TMP(TMPIND,$J,"SRC","USER")_" at "_^TMP(TMPIND,$J,"SRC","SITE")
. S DESL("DATEP")=^TMP(TMPIND,$J,"SRC","DATE")
. S DESL("VRSN")=VERSN
. S DESC="^TMP(TMPIND,$J,""DESC"")"
. S KEYWORD="^TMP(TMPIND,$J,""KEYWORD"")"
. D DESC^PXRMEXU1(IENROOT(1),.DESL,$NA(@DESC),$NA(@KEYWORD))
. F IND=1:1:LC D
.. S LINE=^TMP("PXRMEXRS",$J,IND,0)
.. I LINE["<FILE_NAME>" S FILENAME=$$GETTAGV^PXRMEXU3(LINE,"<FILE_NAME>",1)
.. I LINE["<POINT_01>" S PT01=$$GETTAGV^PXRMEXU3(LINE,"<POINT_01>",1)
.. I LINE["<INTERNAL_ENTRY_NUMBER>" S IEN=$$GETTAGV^PXRMEXU3(LINE,"<INTERNAL_ENTRY_NUMBER>",1)
..;Use 1024 to be conservative.
.. I $L(LINE)<1025 Q
.. D MLWARN(FILENAME,PT01,IEN,LINE,1024)
K ^TMP($J,"CIND"),^TMP("PXRMEXRS",$J)
K ^TMP(TMPIND,$J),^TMP("PXRMEXCS",$J)
Q
;
;=================================
XMLOUT(IEN) ;Write out the XML content of repository entry ien.
N LC,NLINES
S NLINES=$O(^PXD(811.8,IEN,100,""),-1)
F LC=1:1:NLINES W !,^PXD(811.8,IEN,100,LC,0)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMEXU2 10967 printed Dec 13, 2024@01:45:18 Page 2
PXRMEXU2 ; SLC/PKR/PJH - Reminder exchange repository utilities, #2.;07/02/2020
+1 ;;2.0;CLINICAL REMINDERS;**6,12,26,45,74**;Feb 04, 2005;Build 5
+2 ;=================================
EXCLASS(IEN) ;Return the class of the Exchange entry.
+1 NEW ENV,TEMP
+2 ;If the Environment has been saved it will be on line 9.
+3 SET TEMP=^PXD(811.8,IEN,100,9,0)
+4 SET ENV=$SELECT(TEMP["<ENV>":$$GETTAGV^PXRMEXU3(TEMP,"<ENV>",0),1:"")
+5 ;If ENV was not found on line 9 search for it.
+6 IF ENV=""
Begin DoDot:1
+7 NEW IND
+8 SET TEMP=""
+9 FOR IND=1:1
if (ENV'="")!(TEMP["</SOURCE>")
QUIT
Begin DoDot:2
+10 SET TEMP=^PXD(811.8,IEN,100,IND,0)
+11 IF TEMP["<ENV>"
SET ENV=$$GETTAGV^PXRMEXU3(TEMP,"<ENV>",0)
End DoDot:2
End DoDot:1
+12 QUIT $SELECT($PIECE(ENV,U,1)="NATREM":1,$GET(PXRMINST)=1:1,$DATA(XPDNM):1,1:0)
+13 ;
+14 ;=================================
FDA(IND,LC,TMPIND,FILENAME) ;Build the XML FDA output.
+1 NEW FIELD,FILENUM,INDEX,INDEX0,JND,SIENS,WPC
+2 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<FILEMAN_FDA>"
+3 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<![CDATA["
+4 ;Get the file number.
+5 SET FILENUM=""
+6 FOR
SET FILENUM=$ORDER(^TMP(TMPIND,$JOB,IND,FILENAME,FILENUM))
if FILENUM=""
QUIT
Begin DoDot:1
+7 ;Get the source IEN string.
+8 SET SIENS=""
+9 FOR
SET SIENS=$ORDER(^TMP(TMPIND,$JOB,IND,FILENAME,FILENUM,SIENS))
if SIENS=""
QUIT
Begin DoDot:2
+10 SET INDEX0=FILENUM_";"_SIENS
+11 ;Get the field number and store the data.
+12 SET FIELD=""
+13 FOR
SET FIELD=$ORDER(^TMP(TMPIND,$JOB,IND,FILENAME,FILENUM,SIENS,FIELD))
if FIELD=""
QUIT
Begin DoDot:3
+14 SET INDEX=INDEX0_";"_FIELD
+15 ;If there is another index past the field then this is a
+16 ;word-processing field.
+17 IF $DATA(^TMP(TMPIND,$JOB,IND,FILENAME,FILENUM,SIENS,FIELD))=11
Begin DoDot:4
+18 SET WPC=$ORDER(^TMP(TMPIND,$JOB,IND,FILENAME,FILENUM,SIENS,FIELD,""),-1)
+19 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)=INDEX_"~WP-start~"_WPC
+20 FOR JND=1:1:WPC
Begin DoDot:5
+21 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)=^TMP(TMPIND,$JOB,IND,FILENAME,FILENUM,SIENS,FIELD,JND)
End DoDot:5
End DoDot:4
+22 IF '$TEST
SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)=INDEX_"~"_^TMP(TMPIND,$JOB,IND,FILENAME,FILENUM,SIENS,FIELD)
End DoDot:3
End DoDot:2
End DoDot:1
+23 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="]]>"
+24 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="</FILEMAN_FDA>"
+25 QUIT
+26 ;
+27 ;=================================
IENROOT(IND,LC,TMPIND,FILENAME) ;Build the XML IEN_ROOT output.
+1 NEW INDEX,VALUE
+2 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<IEN_ROOT>"
+3 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<![CDATA["
+4 SET INDEX=0
+5 FOR
SET INDEX=$ORDER(^TMP(TMPIND,$JOB,IND,FILENAME,INDEX))
if INDEX=""
QUIT
Begin DoDot:1
+6 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)=INDEX_U_^TMP(TMPIND,$JOB,IND,FILENAME,INDEX)
End DoDot:1
+7 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="]]>"
+8 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="</IEN_ROOT>"
+9 QUIT
+10 ;
+11 ;=================================
MLWARN(FILENAME,PT01,IEN,LINE,MAXLEN) ;Issue a warning if the length of the
+1 ;line exceeds the maximum allowed value.
+2 NEW DATA,INDICES,FIELD,LEN,TEXT
+3 SET LEN=$LENGTH(LINE)
+4 SET INDICES=$PIECE(LINE,"~",1)
+5 SET FIELD=$PIECE(INDICES,";",3)
+6 SET DATA=$PIECE(LINE,"~",2)
+7 SET TEXT(1)="Warning the following line exceeds the VistA maximum allowed length of "_MAXLEN_"."
+8 SET TEXT(2)="Therefore this Exchange entry will not transport correctly."
+9 SET TEXT(3)="Line: "_LINE
+10 SET TEXT(4)="Its length is: "_LEN
+11 SET TEXT(5)="Component: "_FILENAME
+12 SET TEXT(6)="Name: "_PT01
+13 SET TEXT(7)="IEN: "_IEN
+14 SET TEXT(8)="Field number: "_FIELD
+15 SET TEXT(9)="Value: "_DATA
+16 SET TEXT(10)=""
+17 DO EN^DDIOL(.TEXT)
+18 HANG 2
+19 QUIT
+20 ;
+21 ;=================================
PATTR(IEN,ATTR) ;If the Reminder Exchange entry has the packing attribute
+1 ;ATTR return 1 otherwise return 0.
+2 IF $DATA(^PXD(811.8,IEN,140,"B",ATTR))
QUIT 1
+3 QUIT 0
+4 ;
+5 ;=================================
STOREPR(SUCCESS,EFNAME,TMPIND,SELLIST) ;^TMP(TMPIND,$J contains data to be
+1 ;stored in the repository. Routines will be found in
+2 ;^TMP(TMPIND,$J,"ROUTINE",ROUTINE NAME,n) where n is the line number.
+3 ;File entries will be found in ^TMP(TMPIND,$J,N,FILENAME,indexes).
+4 ;This is output from the GETS^DIQ call. There are NUMF file entries.
+5 ;Format and store it as XML in the repository.
+6 NEW DATE,DTEST,FDA,FILENAME,FILENUM,IEN
+7 NEW IENROOT,IND,JND,LC,LINE,NCMPNT,NEWFILE,NUMF,PT01,RNAME
+8 NEW SIENS,SOURCE,TEMP,VERSN
+9 ;If anything went wrong in the packing process then ^TMP(TMPIND,$J
+10 ;will not exist.
+11 IF '$DATA(^TMP(TMPIND,$JOB))
SET SUCCESS=0
QUIT
+12 ;
+13 KILL ^TMP($JOB,"CIND")
+14 KILL ^TMP("PXRMEXRS",$JOB)
+15 SET ^TMP("PXRMEXRS",$JOB,1,0)="<?xml version=""1.0"" standalone=""yes""?>"
+16 SET ^TMP("PXRMEXRS",$JOB,2,0)="<REMINDER_EXCHANGE_FILE_ENTRY>"
+17 SET VERSN=$PIECE(^PXRM(800,1,"VERSION"),U,1)
+18 SET ^TMP("PXRMEXRS",$JOB,3,0)="<PACKAGE_VERSION>"_VERSN_"</PACKAGE_VERSION>"
+19 ;The pointer to the index will be on line 4 so leave room.
+20 SET LC=4
+21 ;Save the source information.
+22 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<SOURCE>"
+23 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<NAME>"_$$TOXML^PXRMEXU3(^TMP(TMPIND,$JOB,"SRC","NAME"))_"</NAME>"
+24 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<USER>"_$$TOXML^PXRMEXU3(^TMP(TMPIND,$JOB,"SRC","USER"))_"</USER>"
+25 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<SITE>"_$$TOXML^PXRMEXU3(^TMP(TMPIND,$JOB,"SRC","SITE"))_"</SITE>"
+26 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<ENV>"_^TMP(TMPIND,$JOB,"SRC","ENV")_"</ENV>"
+27 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<DATE_PACKED>"_^TMP(TMPIND,$JOB,"SRC","DATE")_"</DATE_PACKED>"
+28 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="</SOURCE>"
+29 ;
+30 ;Save the description.
+31 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<DESCRIPTION><![CDATA["
+32 SET IND=0
+33 FOR
SET IND=$ORDER(^TMP(TMPIND,$JOB,"DESC",1,IND))
if +IND=0
QUIT
Begin DoDot:1
+34 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)=^TMP(TMPIND,$JOB,"DESC",1,IND,0)
End DoDot:1
+35 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="]]></DESCRIPTION>"
+36 ;
+37 ;Save the keywords or phrases.
+38 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<KEYWORDS>"
+39 SET IND=0
+40 FOR
SET IND=$ORDER(^TMP(TMPIND,$JOB,"KEYWORD",1,IND))
if +IND=0
QUIT
Begin DoDot:1
+41 SET TEMP=^TMP(TMPIND,$JOB,"KEYWORD",1,IND,0)
+42 IF TEMP[","
Begin DoDot:2
+43 FOR JND=1:1:$LENGTH(TEMP,",")
Begin DoDot:3
+44 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<KEYWORD>"_$$TOXML^PXRMEXU3($PIECE(TEMP,",",JND))_"</KEYWORD>"
End DoDot:3
End DoDot:2
+45 IF '$TEST
SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<KEYWORD>"_$$TOXML^PXRMEXU3(TEMP)_"</KEYWORD>"
End DoDot:1
+46 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="</KEYWORDS>"
+47 ;
+48 ;Save the packing attributes.
+49 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<PACKING ATTRIBUTES><![CDATA["
+50 SET IND=0
+51 FOR
SET IND=$ORDER(^TMP(TMPIND,$JOB,"PATTR",IND))
if +IND=0
QUIT
Begin DoDot:1
+52 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<ATTRIBUTE>"_^TMP(TMPIND,$JOB,"PATTR",IND)_"</ATTRIBUTE>"
End DoDot:1
+53 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="]]></PACKING ATTRIBUTES>"
+54 ;
+55 SET NCMPNT=0
+56 ;Do routines first.
+57 SET RNAME=""
+58 FOR
SET RNAME=$ORDER(^TMP(TMPIND,$JOB,"ROUTINE",RNAME))
if RNAME=""
QUIT
Begin DoDot:1
+59 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<M_ROUTINE>"
+60 SET NCMPNT=NCMPNT+1
+61 SET ^TMP($JOB,"CIND",NCMPNT,"M_ROUTINE_START")=LC
+62 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<ROUTINE_NAME>"_RNAME_"</ROUTINE_NAME>"
+63 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<CHECKSUM>"_^TMP("PXRMEXCS",$JOB,"ROUTINE",RNAME)_"</CHECKSUM>"
+64 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<CODE>"
+65 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<![CDATA["
+66 SET ^TMP($JOB,"CIND",NCMPNT,"ROUTINE_CODE_START")=LC+1
+67 SET LINE=0
+68 FOR
SET LINE=$ORDER(^TMP(TMPIND,$JOB,"ROUTINE",RNAME,LINE))
if LINE=""
QUIT
Begin DoDot:2
+69 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)=^TMP(TMPIND,$JOB,"ROUTINE",RNAME,LINE,0)
End DoDot:2
+70 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="]]>"
+71 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="</CODE>"
+72 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="</M_ROUTINE>"
+73 SET ^TMP($JOB,"CIND",NCMPNT,"ROUTINE_CODE_END")=LC-3
End DoDot:1
+74 ;
+75 ;Do file entries. For word processing fields the first line is
+76 ;file number;source ien string;field~WP-start~line count
+77 ;The next line count lines are the WP data.
+78 SET NUMF=+$GET(^TMP(TMPIND,$JOB,"NUMF"))
+79 SET FILENAME=""
+80 FOR IND=1:1:NUMF
Begin DoDot:1
+81 FOR
SET FILENAME=$ORDER(^TMP(TMPIND,$JOB,IND,FILENAME))
if FILENAME=""
QUIT
Begin DoDot:2
+82 IF FILENAME["IENROOT"
SET NEWFILE=0
SET IENROOT=1
+83 IF '$TEST
SET NEWFILE=1
SET IENROOT=0
+84 IF NEWFILE
Begin DoDot:3
+85 SET FILENUM=$ORDER(^TMP(TMPIND,$JOB,IND,FILENAME,""))
+86 SET SIENS=$ORDER(^TMP(TMPIND,$JOB,IND,FILENAME,FILENUM,""))
+87 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<FILEMAN_FILE>"
+88 SET NCMPNT=NCMPNT+1
+89 SET ^TMP($JOB,"CIND",NCMPNT,"FILE_START")=LC
+90 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<FILE_NAME>"_$$TOXML^PXRMEXU3(FILENAME)_"</FILE_NAME>"
+91 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<FILE_NUMBER>"_FILENUM_"</FILE_NUMBER>"
+92 SET LC=LC+1
SET PT01=^TMP(TMPIND,$JOB,IND,FILENAME,FILENUM,SIENS,.01)
+93 SET ^TMP("PXRMEXRS",$JOB,LC,0)="<POINT_01>"_$$TOXML^PXRMEXU3(PT01)_"</POINT_01>"
+94 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<INTERNAL_ENTRY_NUMBER>"_+SIENS_"</INTERNAL_ENTRY_NUMBER>"
+95 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<CHECKSUM>"_^TMP("PXRMEXCS",$JOB,IND,FILENAME)_"</CHECKSUM>"
+96 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<SELECTED>"_$SELECT($DATA(SELLIST(FILENUM,"IEN",+SIENS)):"YES",1:"NO")_"</SELECTED>"
+97 SET ^TMP($JOB,"CIND",NCMPNT,"FDA_START")=LC+3
+98 DO FDA(IND,.LC,TMPIND,FILENAME)
+99 SET ^TMP($JOB,"CIND",NCMPNT,"FDA_END")=LC-2
End DoDot:3
+100 ;The ien root information always comes after the FDA.
+101 IF IENROOT
Begin DoDot:3
+102 SET ^TMP($JOB,"CIND",NCMPNT,"IEN_ROOT_START")=LC+3
+103 DO IENROOT(IND,.LC,TMPIND,FILENAME)
+104 SET ^TMP($JOB,"CIND",NCMPNT,"IEN_ROOT_END")=LC-2
End DoDot:3
End DoDot:2
+105 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="</FILEMAN_FILE>"
End DoDot:1
+106 ;Save the index.
+107 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,4,0)="<INDEX_AT>"_LC_"</INDEX_AT>"
+108 SET ^TMP("PXRMEXRS",$JOB,LC,0)="<INDEX>"
+109 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<NUMBER_OF_COMPONENTS>"_NCMPNT_"</NUMBER_OF_COMPONENTS>"
+110 FOR IND=1:1:NCMPNT
Begin DoDot:1
+111 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<COMPONENT>"
+112 SET JND=""
+113 FOR
SET JND=$ORDER(^TMP($JOB,"CIND",IND,JND))
if JND=""
QUIT
Begin DoDot:2
+114 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="<"_JND_">"_^TMP($JOB,"CIND",IND,JND)_"</"_JND_">"
End DoDot:2
+115 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="</COMPONENT>"
End DoDot:1
+116 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="</INDEX>"
+117 SET LC=LC+1
SET ^TMP("PXRMEXRS",$JOB,LC,0)="</REMINDER_EXCHANGE_FILE_ENTRY>"
+118 ;Establish the entry in the repository.
+119 SET SOURCE=^TMP(TMPIND,$JOB,"SRC","USER")_" at "_^TMP(TMPIND,$JOB,"SRC","SITE")
+120 SET DATE=^TMP(TMPIND,$JOB,"SRC","DATE")
+121 SET FDA(811.8,"+1,",.01)=EFNAME
+122 SET FDA(811.8,"+1,",.02)=SOURCE
+123 SET FDA(811.8,"+1,",.03)=DATE
+124 DO UPDATE^PXRMEXPU(.SUCCESS,.FDA,.IENROOT)
+125 IF SUCCESS
Begin DoDot:1
+126 MERGE ^PXD(811.8,IENROOT(1),100)=^TMP("PXRMEXRS",$JOB)
+127 ;Set the 0 node.
+128 SET ^PXD(811.8,IENROOT(1),100,0)=U_811.801_U_LC_U_LC
+129 ;Create the description for this repository entry.
+130 NEW DESC,DESL,KEYWORD
+131 SET DESL("SOURCE")=^TMP(TMPIND,$JOB,"SRC","USER")_" at "_^TMP(TMPIND,$JOB,"SRC","SITE")
+132 SET DESL("DATEP")=^TMP(TMPIND,$JOB,"SRC","DATE")
+133 SET DESL("VRSN")=VERSN
+134 SET DESC="^TMP(TMPIND,$J,""DESC"")"
+135 SET KEYWORD="^TMP(TMPIND,$J,""KEYWORD"")"
+136 DO DESC^PXRMEXU1(IENROOT(1),.DESL,$NAME(@DESC),$NAME(@KEYWORD))
+137 FOR IND=1:1:LC
Begin DoDot:2
+138 SET LINE=^TMP("PXRMEXRS",$JOB,IND,0)
+139 IF LINE["<FILE_NAME>"
SET FILENAME=$$GETTAGV^PXRMEXU3(LINE,"<FILE_NAME>",1)
+140 IF LINE["<POINT_01>"
SET PT01=$$GETTAGV^PXRMEXU3(LINE,"<POINT_01>",1)
+141 IF LINE["<INTERNAL_ENTRY_NUMBER>"
SET IEN=$$GETTAGV^PXRMEXU3(LINE,"<INTERNAL_ENTRY_NUMBER>",1)
+142 ;Use 1024 to be conservative.
+143 IF $LENGTH(LINE)<1025
QUIT
+144 DO MLWARN(FILENAME,PT01,IEN,LINE,1024)
End DoDot:2
End DoDot:1
+145 KILL ^TMP($JOB,"CIND"),^TMP("PXRMEXRS",$JOB)
+146 KILL ^TMP(TMPIND,$JOB),^TMP("PXRMEXCS",$JOB)
+147 QUIT
+148 ;
+149 ;=================================
XMLOUT(IEN) ;Write out the XML content of repository entry ien.
+1 NEW LC,NLINES
+2 SET NLINES=$ORDER(^PXD(811.8,IEN,100,""),-1)
+3 FOR LC=1:1:NLINES
WRITE !,^PXD(811.8,IEN,100,LC,0)
+4 QUIT
+5 ;
