- PXRMEXU1 ; SLC/PKR/PJH - Reminder exchange repository utilities, #1.;10/23/2020
- ;;2.0;CLINICAL REMINDERS;**6,12,16,26,45,42**;Feb 04, 2005;Build 245
- ;=====================================================
- DELETE(LIST) ;Delete the repository entries in LIST.
- N DA,DIK,IND,LNUM
- S DIK="^PXD(811.8,"
- F IND=1:1:$L(LIST,",")-1 D
- . S LNUM=$P(LIST,",",IND)
- . S DA=$$RIEN^PXRMEXU1(LNUM)
- . D ^DIK
- Q
- ;
- ;=====================================================
- DELHIST(RIEN,IHIEN) ;Delete install history IHIEN in repository entry RIEN.
- N DA,DIK
- S DA=IHIEN,DA(1)=RIEN
- S DIK="^PXD(811.8,"_DA(1)_",130,"
- D ^DIK
- Q
- ;
- ;=====================================================
- DESC(RIEN,DESL,DESC,KEYWORD) ;Build the description.
- N JND,LC,NKEYWL
- S LC=1,^PXD(811.8,RIEN,110,LC,0)="Source: "_DESL("SOURCE")
- S LC=LC+1,^PXD(811.8,RIEN,110,LC,0)="Date Packed: "_DESL("DATEP")
- S LC=LC+1,^PXD(811.8,RIEN,110,LC,0)="Package Version: "_DESL("VRSN")
- S LC=LC+1,^PXD(811.8,RIEN,110,LC,0)=""
- ;Add the user's description.
- S LC=LC+1,^PXD(811.8,RIEN,110,LC,0)="Description:"
- F JND=1:1:+$P($G(@DESC@(1,0)),U,4) D
- . S LC=LC+1,^PXD(811.8,RIEN,110,LC,0)=@DESC@(1,JND,0)
- S LC=LC+1,^PXD(811.8,RIEN,110,LC,0)=""
- ;Add the keywords.
- S LC=LC+1,^PXD(811.8,RIEN,110,LC,0)="Keywords:"
- S NKEYWL=+$P($G(@KEYWORD@(1,0)),U,4)
- F JND=1:1:NKEYWL D
- . S LC=LC+1,^PXD(811.8,RIEN,110,LC,0)=@KEYWORD@(1,JND,0)
- S LC=LC+1,^PXD(811.8,RIEN,110,LC,0)=""
- S LC=LC+1,^PXD(811.8,RIEN,110,LC,0)="Components:"
- S ^PXD(811.8,RIEN,110,0)=U_811.804_U_LC_U_LC
- Q
- ;
- ;=====================================================
- RIEN(LNUM) ;Given the list number return the repository ien.
- N RIEN
- S RIEN=$G(^TMP("PXRMEXLR",$J,"SEL",LNUM))
- Q RIEN
- ;
- ;=====================================================
- PATTR(IEN) ;Build the Packing Attribute list.
- N ATTRLIST,DONE,FDA,IENS,INDEXAT,LN,MSG,NATTR,TEXT
- S TEXT=^PXD(811.8,IEN,100,4,0)
- S INDEXAT=$$GETTAGV^PXRMEXU3(TEXT,"<INDEX_AT>",10)
- S (DONE,NATTR)=0
- S LN=10
- F Q:DONE D
- . S LN=LN+1
- . I LN=INDEXAT S DONE=1 Q
- . S TEXT=^PXD(811.8,IEN,100,LN,0)
- . I TEXT["</ATTRIBUTE>" S NATTR=NATTR+1,ATTRLIST(NATTR)=$$GETTAGV^PXRMEXU3(TEXT,"<ATTRIBUTE>",11)
- . I TEXT["</PACKING ATTRIBUTES>" S DONE=1 Q
- I NATTR=0 S NATTR=1,ATTRLIST(1)="NONE"
- F LN=1:1:NATTR D
- . S IENS="+"_LN_","_IEN_","
- . S FDA(811.805,IENS,.01)=ATTRLIST(LN)
- D UPDATE^DIE("S","FDA","","MSG")
- I $D(MSG) D
- . K TEXT
- . S TEXT(1)="Storage of the Packing Attributes failed."
- . S TEXT(2)="Examine the following error message for the reason."
- . S TEXT(3)=""
- . S TEXT(4)="The update failed, UPDATE^DIE returned the following error message:"
- . D MES^XPDUTL(.TEXT)
- . D AWRITE^PXRMUTIL("MSG")
- Q
- ;
- ;=====================================================
- SAVHIST ;Save the installation history in the repository.
- N ACTION,DATE,CMPNT,FTYPE,IND,INDEX,ITEM,JND,KND,NEWNAME
- N SUB,TEMP,TOTAL,TYPE,USER
- ;Find the first open spot in the Installation History node.
- S (IND,JND)=0
- F S IND=+$O(^PXD(811.8,PXRMRIEN,130,IND)) S JND=JND+1 Q:(IND=0)!(IND>JND)
- S IND=JND
- S JND=0
- F SUB="PXRMEXIA","PXRMEXIAD" D
- . S INDEX=0
- . F S INDEX=$O(^TMP(SUB,$J,INDEX)) Q:+INDEX=0 D
- .. S JND=JND+1
- .. S CMPNT=$O(^TMP(SUB,$J,INDEX,""))
- .. S ITEM=$O(^TMP(SUB,$J,INDEX,CMPNT,""))
- .. S ACTION=$O(^TMP(SUB,$J,INDEX,CMPNT,ITEM,""))
- .. S NEWNAME=$G(^TMP(SUB,$J,INDEX,CMPNT,ITEM,ACTION))
- .. S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,0)=INDEX_U_CMPNT_U_ITEM_U_ACTION_U_NEWNAME
- ..;Set the 0 node.
- .. S ^PXD(811.8,PXRMRIEN,130,IND,1,0)=U_"811.8031A"_U_JND_U_JND
- ..;Check for finding item changes and save them.
- .. S FTYPE=""
- .. I CMPNT["DEFINITION" S FTYPE="DEFF"
- .. I CMPNT["DIALOG" S FTYPE="DIAF"
- .. I CMPNT["TERM" S FTYPE="TRMF"
- .. I (FTYPE'=""),($D(^TMP(SUB,$J,FTYPE))) D
- ... N FI,FINDING,OFINDING
- ... S KND=2
- ... S FI=""
- ... F S FI=$O(^TMP(SUB,$J,FTYPE,FI)) Q:FI="" D
- .... S OFINDING=$O(^TMP(SUB,$J,FTYPE,FI,""))
- .... S FINDING=^TMP(SUB,$J,FTYPE,FI,OFINDING)
- .... I OFINDING=FINDING Q
- .... S KND=KND+1
- .... S TEMP=$E(OFINDING,1,33)
- .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,KND,0)=" "_TEMP_$$INSCHR^PXRMEXLC((35-$L(TEMP))," ")_FINDING
- ... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,0)=U_"811.80315A"_U_KND_U_KND
- ... I KND>2 D
- .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,1,0)=" Finding Changes"
- .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,2,0)=" Original"_$$INSCHR^PXRMEXLC(27," ")_"New"
- ..;
- ..;Check for TIU template replacements and save them.
- .. I CMPNT["DIALOG" S FTYPE="DIATIU"
- .. E S FTYPE=""
- .. I (FTYPE'=""),($D(^TMP(SUB,$J,FTYPE))) D
- ... N OTIUT,TIUT,TYPE
- ... S TYPE=""
- ... S KND=2
- ... F S TYPE=$O(^TMP(SUB,$J,FTYPE,TYPE)) Q:TYPE="" D
- .... S OTIUT=""
- .... F S OTIUT=$O(^TMP(SUB,$J,FTYPE,TYPE,OTIUT)) Q:OTIUT="" D
- ..... S TIUT=$G(^TMP(SUB,$J,FTYPE,TYPE,OTIUT))
- ..... I OTIUT=TIUT Q
- ..... I '$D(^TMP(SUB,$J,FTYPE,TYPE,OTIUT,ITEM)) Q
- ..... S KND=KND+1
- ..... S TEMP=$E(OTIUT,1,33)
- ..... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,KND,0)=" "_TEMP_$$INSCHR^PXRMEXLC((35-$L(TEMP))," ")_TIUT
- .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,0)=U_"811.80315A"_U_KND_U_KND
- .... I KND>2 D
- ..... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,1,0)=" "_TYPE
- ..... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,2,0)=" Original"_$$INSCHR^PXRMEXLC(27," ")_"New"
- ;If JND is still 0 then there was nothing to save.
- I JND>0 D
- .;Save the header information.
- . S DATE=$$NOW^XLFDT
- . S TYPE=$G(^TMP("PXRMEXIA",$J,"TYPE"))
- . I TYPE="" S TYPE="INTERACTIVE"
- . S USER=$$GET1^DIQ(200,DUZ,.01,"")
- . S ^PXD(811.8,PXRMRIEN,130,IND,0)=DATE_U_USER_U_TYPE
- . S ^PXD(811.8,PXRMRIEN,130,"B",DATE,IND)=""
- .;Set the 0 node.
- . S (KND,TOTAL)=0
- . F S KND=+$O(^PXD(811.8,PXRMRIEN,130,KND)) Q:KND=0 S TOTAL=TOTAL+1
- . S ^PXD(811.8,PXRMRIEN,130,0)=U_"811.803DA"_U_IND_U_TOTAL
- K ^TMP("PXRMEXIA",$J)
- K ^TMP("PXRMEXIAD",$J)
- Q
- ;
- ;=====================================================
- TIUSRCH(GLOB,IEN,NODE,OLIST,TLIST) ;Extract TIU Objects/Templates
- ;from any WP text.
- N NIN,NOUT,OCNT,SUB,TCNT,TEXT,TEXTIN,TEXTOUT
- ;Add to existing arrays
- S NIN=0
- S OCNT=+$O(OLIST(""),-1),TCNT=+$O(TLIST(""),-1),SUB=0
- ;Scan WP fields
- F S SUB=$O(@(GLOB_IEN_","_NODE_","_SUB_")")) Q:'SUB D
- .;Get individual line
- .S TEXT=$G(@(GLOB_IEN_","_NODE_","_SUB_",0)")) Q:TEXT=""
- .S NIN=NIN+1
- .S TEXTIN(NIN)=TEXT
- D FORMAT^PXRMTEXT(0,80,NIN,.TEXTIN,.NOUT,.TEXTOUT)
- F X=1:1:NOUT D
- .S TEXT=TEXTOUT(X)
- .;Most text lines will have no TIU link so ignore them
- .I (TEXT'["|")&(TEXT'["{FLD:") Q
- .;Templates are in format {FLD:fldname} (only applies to dialogs)
- .I GLOB[801.41 D TIUXTR("{FLD:","}",TEXT,.TLIST,.TCNT)
- .;Objects are in format |Objectname|
- .D TIUXTR("|","|",TEXT,.OLIST,.OCNT)
- Q
- ;
- ;=====================================================
- TIUXTR(SRCH,SRCH1,TEXT,OUTPUT,CNT) ;
- N EXIST,IC,ONAME,TMP,TXT
- S TXT=TEXT
- F D Q:TXT'[SRCH
- .S TXT=$E(TXT,$F(TXT,SRCH),$L(TXT)) Q:TXT'[SRCH1
- .S ONAME=$P(TXT,SRCH1) Q:ONAME=""
- .I SRCH1="}" S TMP=$P(TXT,SRCH1,2) I $E(TMP,1,3)="FMT" Q
- .;
- .;Remove the valid item from the text string. This prevent problems
- .;with multiple objects on one line.
- .;
- .S TXT=$P(TXT,ONAME_SRCH1,2)
- .;Check if already selected
- .S EXIST=0,IC=0
- .F S IC=$O(OUTPUT(IC)) Q:'IC Q:EXIST D
- ..I $G(OUTPUT(IC))=ONAME S EXIST=1
- .;Save array of object/template names
- .I 'EXIST S CNT=CNT+1,OUTPUT(CNT)=ONAME
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMEXU1 7483 printed Jan 18, 2025@02:46:30 Page 2
- PXRMEXU1 ; SLC/PKR/PJH - Reminder exchange repository utilities, #1.;10/23/2020
- +1 ;;2.0;CLINICAL REMINDERS;**6,12,16,26,45,42**;Feb 04, 2005;Build 245
- +2 ;=====================================================
- DELETE(LIST) ;Delete the repository entries in LIST.
- +1 NEW DA,DIK,IND,LNUM
- +2 SET DIK="^PXD(811.8,"
- +3 FOR IND=1:1:$LENGTH(LIST,",")-1
- Begin DoDot:1
- +4 SET LNUM=$PIECE(LIST,",",IND)
- +5 SET DA=$$RIEN^PXRMEXU1(LNUM)
- +6 DO ^DIK
- End DoDot:1
- +7 QUIT
- +8 ;
- +9 ;=====================================================
- DELHIST(RIEN,IHIEN) ;Delete install history IHIEN in repository entry RIEN.
- +1 NEW DA,DIK
- +2 SET DA=IHIEN
- SET DA(1)=RIEN
- +3 SET DIK="^PXD(811.8,"_DA(1)_",130,"
- +4 DO ^DIK
- +5 QUIT
- +6 ;
- +7 ;=====================================================
- DESC(RIEN,DESL,DESC,KEYWORD) ;Build the description.
- +1 NEW JND,LC,NKEYWL
- +2 SET LC=1
- SET ^PXD(811.8,RIEN,110,LC,0)="Source: "_DESL("SOURCE")
- +3 SET LC=LC+1
- SET ^PXD(811.8,RIEN,110,LC,0)="Date Packed: "_DESL("DATEP")
- +4 SET LC=LC+1
- SET ^PXD(811.8,RIEN,110,LC,0)="Package Version: "_DESL("VRSN")
- +5 SET LC=LC+1
- SET ^PXD(811.8,RIEN,110,LC,0)=""
- +6 ;Add the user's description.
- +7 SET LC=LC+1
- SET ^PXD(811.8,RIEN,110,LC,0)="Description:"
- +8 FOR JND=1:1:+$PIECE($GET(@DESC@(1,0)),U,4)
- Begin DoDot:1
- +9 SET LC=LC+1
- SET ^PXD(811.8,RIEN,110,LC,0)=@DESC@(1,JND,0)
- End DoDot:1
- +10 SET LC=LC+1
- SET ^PXD(811.8,RIEN,110,LC,0)=""
- +11 ;Add the keywords.
- +12 SET LC=LC+1
- SET ^PXD(811.8,RIEN,110,LC,0)="Keywords:"
- +13 SET NKEYWL=+$PIECE($GET(@KEYWORD@(1,0)),U,4)
- +14 FOR JND=1:1:NKEYWL
- Begin DoDot:1
- +15 SET LC=LC+1
- SET ^PXD(811.8,RIEN,110,LC,0)=@KEYWORD@(1,JND,0)
- End DoDot:1
- +16 SET LC=LC+1
- SET ^PXD(811.8,RIEN,110,LC,0)=""
- +17 SET LC=LC+1
- SET ^PXD(811.8,RIEN,110,LC,0)="Components:"
- +18 SET ^PXD(811.8,RIEN,110,0)=U_811.804_U_LC_U_LC
- +19 QUIT
- +20 ;
- +21 ;=====================================================
- RIEN(LNUM) ;Given the list number return the repository ien.
- +1 NEW RIEN
- +2 SET RIEN=$GET(^TMP("PXRMEXLR",$JOB,"SEL",LNUM))
- +3 QUIT RIEN
- +4 ;
- +5 ;=====================================================
- PATTR(IEN) ;Build the Packing Attribute list.
- +1 NEW ATTRLIST,DONE,FDA,IENS,INDEXAT,LN,MSG,NATTR,TEXT
- +2 SET TEXT=^PXD(811.8,IEN,100,4,0)
- +3 SET INDEXAT=$$GETTAGV^PXRMEXU3(TEXT,"<INDEX_AT>",10)
- +4 SET (DONE,NATTR)=0
- +5 SET LN=10
- +6 FOR
- if DONE
- QUIT
- Begin DoDot:1
- +7 SET LN=LN+1
- +8 IF LN=INDEXAT
- SET DONE=1
- QUIT
- +9 SET TEXT=^PXD(811.8,IEN,100,LN,0)
- +10 IF TEXT["</ATTRIBUTE>"
- SET NATTR=NATTR+1
- SET ATTRLIST(NATTR)=$$GETTAGV^PXRMEXU3(TEXT,"<ATTRIBUTE>",11)
- +11 IF TEXT["</PACKING ATTRIBUTES>"
- SET DONE=1
- QUIT
- End DoDot:1
- +12 IF NATTR=0
- SET NATTR=1
- SET ATTRLIST(1)="NONE"
- +13 FOR LN=1:1:NATTR
- Begin DoDot:1
- +14 SET IENS="+"_LN_","_IEN_","
- +15 SET FDA(811.805,IENS,.01)=ATTRLIST(LN)
- End DoDot:1
- +16 DO UPDATE^DIE("S","FDA","","MSG")
- +17 IF $DATA(MSG)
- Begin DoDot:1
- +18 KILL TEXT
- +19 SET TEXT(1)="Storage of the Packing Attributes failed."
- +20 SET TEXT(2)="Examine the following error message for the reason."
- +21 SET TEXT(3)=""
- +22 SET TEXT(4)="The update failed, UPDATE^DIE returned the following error message:"
- +23 DO MES^XPDUTL(.TEXT)
- +24 DO AWRITE^PXRMUTIL("MSG")
- End DoDot:1
- +25 QUIT
- +26 ;
- +27 ;=====================================================
- SAVHIST ;Save the installation history in the repository.
- +1 NEW ACTION,DATE,CMPNT,FTYPE,IND,INDEX,ITEM,JND,KND,NEWNAME
- +2 NEW SUB,TEMP,TOTAL,TYPE,USER
- +3 ;Find the first open spot in the Installation History node.
- +4 SET (IND,JND)=0
- +5 FOR
- SET IND=+$ORDER(^PXD(811.8,PXRMRIEN,130,IND))
- SET JND=JND+1
- if (IND=0)!(IND>JND)
- QUIT
- +6 SET IND=JND
- +7 SET JND=0
- +8 FOR SUB="PXRMEXIA","PXRMEXIAD"
- Begin DoDot:1
- +9 SET INDEX=0
- +10 FOR
- SET INDEX=$ORDER(^TMP(SUB,$JOB,INDEX))
- if +INDEX=0
- QUIT
- Begin DoDot:2
- +11 SET JND=JND+1
- +12 SET CMPNT=$ORDER(^TMP(SUB,$JOB,INDEX,""))
- +13 SET ITEM=$ORDER(^TMP(SUB,$JOB,INDEX,CMPNT,""))
- +14 SET ACTION=$ORDER(^TMP(SUB,$JOB,INDEX,CMPNT,ITEM,""))
- +15 SET NEWNAME=$GET(^TMP(SUB,$JOB,INDEX,CMPNT,ITEM,ACTION))
- +16 SET ^PXD(811.8,PXRMRIEN,130,IND,1,JND,0)=INDEX_U_CMPNT_U_ITEM_U_ACTION_U_NEWNAME
- +17 ;Set the 0 node.
- +18 SET ^PXD(811.8,PXRMRIEN,130,IND,1,0)=U_"811.8031A"_U_JND_U_JND
- +19 ;Check for finding item changes and save them.
- +20 SET FTYPE=""
- +21 IF CMPNT["DEFINITION"
- SET FTYPE="DEFF"
- +22 IF CMPNT["DIALOG"
- SET FTYPE="DIAF"
- +23 IF CMPNT["TERM"
- SET FTYPE="TRMF"
- +24 IF (FTYPE'="")
- IF ($DATA(^TMP(SUB,$JOB,FTYPE)))
- Begin DoDot:3
- +25 NEW FI,FINDING,OFINDING
- +26 SET KND=2
- +27 SET FI=""
- +28 FOR
- SET FI=$ORDER(^TMP(SUB,$JOB,FTYPE,FI))
- if FI=""
- QUIT
- Begin DoDot:4
- +29 SET OFINDING=$ORDER(^TMP(SUB,$JOB,FTYPE,FI,""))
- +30 SET FINDING=^TMP(SUB,$JOB,FTYPE,FI,OFINDING)
- +31 IF OFINDING=FINDING
- QUIT
- +32 SET KND=KND+1
- +33 SET TEMP=$EXTRACT(OFINDING,1,33)
- +34 SET ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,KND,0)=" "_TEMP_$$INSCHR^PXRMEXLC((35-$LENGTH(TEMP))," ")_FINDING
- End DoDot:4
- +35 SET ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,0)=U_"811.80315A"_U_KND_U_KND
- +36 IF KND>2
- Begin DoDot:4
- +37 SET ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,1,0)=" Finding Changes"
- +38 SET ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,2,0)=" Original"_$$INSCHR^PXRMEXLC(27," ")_"New"
- End DoDot:4
- End DoDot:3
- +39 ;
- +40 ;Check for TIU template replacements and save them.
- +41 IF CMPNT["DIALOG"
- SET FTYPE="DIATIU"
- +42 IF '$TEST
- SET FTYPE=""
- +43 IF (FTYPE'="")
- IF ($DATA(^TMP(SUB,$JOB,FTYPE)))
- Begin DoDot:3
- +44 NEW OTIUT,TIUT,TYPE
- +45 SET TYPE=""
- +46 SET KND=2
- +47 FOR
- SET TYPE=$ORDER(^TMP(SUB,$JOB,FTYPE,TYPE))
- if TYPE=""
- QUIT
- Begin DoDot:4
- +48 SET OTIUT=""
- +49 FOR
- SET OTIUT=$ORDER(^TMP(SUB,$JOB,FTYPE,TYPE,OTIUT))
- if OTIUT=""
- QUIT
- Begin DoDot:5
- +50 SET TIUT=$GET(^TMP(SUB,$JOB,FTYPE,TYPE,OTIUT))
- +51 IF OTIUT=TIUT
- QUIT
- +52 IF '$DATA(^TMP(SUB,$JOB,FTYPE,TYPE,OTIUT,ITEM))
- QUIT
- +53 SET KND=KND+1
- +54 SET TEMP=$EXTRACT(OTIUT,1,33)
- +55 SET ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,KND,0)=" "_TEMP_$$INSCHR^PXRMEXLC((35-$LENGTH(TEMP))," ")_TIUT
- End DoDot:5
- +56 SET ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,0)=U_"811.80315A"_U_KND_U_KND
- +57 IF KND>2
- Begin DoDot:5
- +58 SET ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,1,0)=" "_TYPE
- +59 SET ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,2,0)=" Original"_$$INSCHR^PXRMEXLC(27," ")_"New"
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +60 ;If JND is still 0 then there was nothing to save.
- +61 IF JND>0
- Begin DoDot:1
- +62 ;Save the header information.
- +63 SET DATE=$$NOW^XLFDT
- +64 SET TYPE=$GET(^TMP("PXRMEXIA",$JOB,"TYPE"))
- +65 IF TYPE=""
- SET TYPE="INTERACTIVE"
- +66 SET USER=$$GET1^DIQ(200,DUZ,.01,"")
- +67 SET ^PXD(811.8,PXRMRIEN,130,IND,0)=DATE_U_USER_U_TYPE
- +68 SET ^PXD(811.8,PXRMRIEN,130,"B",DATE,IND)=""
- +69 ;Set the 0 node.
- +70 SET (KND,TOTAL)=0
- +71 FOR
- SET KND=+$ORDER(^PXD(811.8,PXRMRIEN,130,KND))
- if KND=0
- QUIT
- SET TOTAL=TOTAL+1
- +72 SET ^PXD(811.8,PXRMRIEN,130,0)=U_"811.803DA"_U_IND_U_TOTAL
- End DoDot:1
- +73 KILL ^TMP("PXRMEXIA",$JOB)
- +74 KILL ^TMP("PXRMEXIAD",$JOB)
- +75 QUIT
- +76 ;
- +77 ;=====================================================
- TIUSRCH(GLOB,IEN,NODE,OLIST,TLIST) ;Extract TIU Objects/Templates
- +1 ;from any WP text.
- +2 NEW NIN,NOUT,OCNT,SUB,TCNT,TEXT,TEXTIN,TEXTOUT
- +3 ;Add to existing arrays
- +4 SET NIN=0
- +5 SET OCNT=+$ORDER(OLIST(""),-1)
- SET TCNT=+$ORDER(TLIST(""),-1)
- SET SUB=0
- +6 ;Scan WP fields
- +7 FOR
- SET SUB=$ORDER(@(GLOB_IEN_","_NODE_","_SUB_")"))
- if 'SUB
- QUIT
- Begin DoDot:1
- +8 ;Get individual line
- +9 SET TEXT=$GET(@(GLOB_IEN_","_NODE_","_SUB_",0)"))
- if TEXT=""
- QUIT
- +10 SET NIN=NIN+1
- +11 SET TEXTIN(NIN)=TEXT
- End DoDot:1
- +12 DO FORMAT^PXRMTEXT(0,80,NIN,.TEXTIN,.NOUT,.TEXTOUT)
- +13 FOR X=1:1:NOUT
- Begin DoDot:1
- +14 SET TEXT=TEXTOUT(X)
- +15 ;Most text lines will have no TIU link so ignore them
- +16 IF (TEXT'["|")&(TEXT'["{FLD:")
- QUIT
- +17 ;Templates are in format {FLD:fldname} (only applies to dialogs)
- +18 IF GLOB[801.41
- DO TIUXTR("{FLD:","}",TEXT,.TLIST,.TCNT)
- +19 ;Objects are in format |Objectname|
- +20 DO TIUXTR("|","|",TEXT,.OLIST,.OCNT)
- End DoDot:1
- +21 QUIT
- +22 ;
- +23 ;=====================================================
- TIUXTR(SRCH,SRCH1,TEXT,OUTPUT,CNT) ;
- +1 NEW EXIST,IC,ONAME,TMP,TXT
- +2 SET TXT=TEXT
- +3 FOR
- Begin DoDot:1
- +4 SET TXT=$EXTRACT(TXT,$FIND(TXT,SRCH),$LENGTH(TXT))
- if TXT'[SRCH1
- QUIT
- +5 SET ONAME=$PIECE(TXT,SRCH1)
- if ONAME=""
- QUIT
- +6 IF SRCH1="}"
- SET TMP=$PIECE(TXT,SRCH1,2)
- IF $EXTRACT(TMP,1,3)="FMT"
- QUIT
- +7 ;
- +8 ;Remove the valid item from the text string. This prevent problems
- +9 ;with multiple objects on one line.
- +10 ;
- +11 SET TXT=$PIECE(TXT,ONAME_SRCH1,2)
- +12 ;Check if already selected
- +13 SET EXIST=0
- SET IC=0
- +14 FOR
- SET IC=$ORDER(OUTPUT(IC))
- if 'IC
- QUIT
- if EXIST
- QUIT
- Begin DoDot:2
- +15 IF $GET(OUTPUT(IC))=ONAME
- SET EXIST=1
- End DoDot:2
- +16 ;Save array of object/template names
- +17 IF 'EXIST
- SET CNT=CNT+1
- SET OUTPUT(CNT)=ONAME
- End DoDot:1
- if TXT'[SRCH
- QUIT
- +18 QUIT
- +19 ;