PXRMEXU1 ; SLC/PKR/PJH - Reminder exchange repository utilities, #1.;01/22/2013
;;2.0;CLINICAL REMINDERS;**6,12,16,26**;Feb 04, 2005;Build 404
;=====================================================
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
;
;=====================================================
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
;
;=====================================================
;Extract TIU Objects/Templates from any WP text
TIUSRCH(GLOB,IEN,NODE,OLIST,TLIST) ;
N OCNT,SUB,TCNT,TEXT
;Add to existing arrays
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=""
.;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,TXT,ONAME
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=""
.;
.;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
;
PXRMEXU1 ; SLC/PKR/PJH - Reminder exchange repository utilities, #1.;01/22/2013
+1 ;;2.0;CLINICAL REMINDERS;**6,12,16,26**;Feb 04, 2005;Build 404
+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 ;=====================================================
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 ;=====================================================
+78 ;Extract TIU Objects/Templates from any WP text
TIUSRCH(GLOB,IEN,NODE,OLIST,TLIST) ;
+1 NEW OCNT,SUB,TCNT,TEXT
+2 ;Add to existing arrays
+3 SET OCNT=+$ORDER(OLIST(""),-1)
SET TCNT=+$ORDER(TLIST(""),-1)
SET SUB=0
+4 ;Scan WP fields
+5 FOR
SET SUB=$ORDER(@(GLOB_IEN_","_NODE_","_SUB_")"))
IF 'SUB
QUIT
Begin DoDot:1
+6 ;Get individual line
+7 SET TEXT=$GET(@(GLOB_IEN_","_NODE_","_SUB_",0)"))
IF TEXT=""
QUIT
+8 ;Most text lines will have no TIU link so ignore them
+9 IF (TEXT'["|")&(TEXT'["{FLD:")
QUIT
+10 ;Templates are in format {FLD:fldname} (only applies to dialogs)
+11 IF GLOB[801.41
DO TIUXTR("{FLD:","}",TEXT,.TLIST,.TCNT)
+12 ;Objects are in format |Objectname|
+13 DO TIUXTR("|","|",TEXT,.OLIST,.OCNT)
End DoDot:1
+14 QUIT
+15 ;
TIUXTR(SRCH,SRCH1,TEXT,OUTPUT,CNT) ;
+1 NEW EXIST,IC,TXT,ONAME
+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 ;
+7 ;remove the valid item from the text string. This prevent problems
+8 ;with multiple objects on one line.
+9 ;
+10 SET TXT=$PIECE(TXT,ONAME_SRCH1,2)
+11 ;Check if already selected
+12 SET EXIST=0
SET IC=0
+13 FOR
SET IC=$ORDER(OUTPUT(IC))
IF 'IC
QUIT
IF EXIST
QUIT
Begin DoDot:2
+14 IF $GET(OUTPUT(IC))=ONAME
SET EXIST=1
End DoDot:2
+15 ;Save array of object/template names
+16 IF 'EXIST
SET CNT=CNT+1
SET OUTPUT(CNT)=ONAME
End DoDot:1
IF TXT'[SRCH
QUIT
+17 QUIT
+18 ;
