PXRMEXU5 ;SLC/PKR - Reminder exchange KIDS utilities, #5. ;06/03/2012
;;2.0;CLINICAL REMINDERS;**12,16,18,22**;Feb 04, 2005;Build 160
;==================================================
BMTABLE(MTABLE,IENROOT,DIQOUT,FDA) ;Build the table for merging
;GETS^DIQOUT indexes into the FDA. The merge table has the form:
;MTABLE(IENSD)=IENSF. IENSD is the DIQOUT iens and IENSF is the
;FDA iens. MTABLE provides a direct replacement of IENSD to IENSF.
N FILENUM,IEN,IENS,IENSD,IENRF,IENSF,IND,LAST,LEN,NULLF,TOPFN
S FILENUM=$O(FDA(""),-1),IENS=$O(FDA(FILENUM,""),-1)
S LAST=+$P(IENS,",",1)
;Initialize the merge table by looking for identical entries in
;DIQOUT and FDA. First create the top level entry.
S NULLF=0
S FILENUM=$O(DIQOUT(""))
S IENSD=$O(DIQOUT(FILENUM,""))
S LEN=$L(IENSD,",")-1
S IENS=$P(IENSD,",",LEN)_","
;DBIA #2631
F IND=1:1:LEN-1 S FILENUM=$G(^DD(FILENUM,0,"UP"))
S TOPFN=FILENUM
S IENSF=$O(FDA(TOPFN,""))
S MTABLE(TOPFN,IENS)=IENSF
;Build all the entries below the top level.
S FILENUM=TOPFN
F S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM="" D
. S IENSD=""
. F S IENSD=$O(DIQOUT(FILENUM,IENSD)) Q:IENSD="" D
.. S MTABLE(FILENUM,IENSD)=""
.. I '$D(FDA(FILENUM)) S NULLF=1 Q
..;Look for matches based on identical .01s
.. S IENSF=""
.. F S IENSF=$O(FDA(FILENUM,IENSF)) Q:IENSF="" D
... I $G(DIQOUT(FILENUM,IENSD,.01))=$G(FDA(FILENUM,IENSF,.01)) S MTABLE(FILENUM,IENSD)=IENSF
... E S NULLF=1
;Entries that are equal to null at this point don't have a
;corresponding FDA entry.
I 'NULLF Q
S FILENUM=""
F S FILENUM=$O(FDA(FILENUM)) Q:FILENUM="" D
. S IENSF=""
. F S IENSF=$O(FDA(FILENUM,IENSF)) Q:IENSF="" D
.. S IND=+IENSF
.. I IENROOT(IND)'="" S IENRF(FILENUM,IENROOT(IND))=IND
;IENRF keeps track of the IENROOT entries by file number.
S FILENUM=""
F S FILENUM=$O(MTABLE(FILENUM)) Q:FILENUM="" D
. S IENSD=""
. F S IENSD=$O(MTABLE(FILENUM,IENSD)) Q:IENSD="" D
.. I MTABLE(FILENUM,IENSD)'="" Q
.. D MMTAB(.MTABLE,.IENROOT,.LAST,FILENUM,IENSD,.IENRF)
Q
;
;==================================================
LOIEN(FILENUM,START) ;Find the first open IEN in a global. If the optional
;parameter START is present then start there looking for the first
;open IEN.
N GBL,I1,I2,OIEN
S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")_"I1)"
S OIEN=-1
S (I1,I2)=0
S (I1,I2)=$S($G(START)>0:START,1:0)
F S I1=+$O(@GBL) Q:(OIEN>0)!(I1=0) D
. I ((I1-I2)>1)!(I1="") S OIEN=I2+1 Q
. S I2=I1
I OIEN=-1 S OIEN=I2+1
Q OIEN
;
;==================================================
MOU(FILENUM,IEN,FIELD,FDA,IENROOT,ACTION,WPTMP) ;Merge or update existing site
;entries into the FDA that is loaded from Exchange.
;FILENUM - the file number
;IEN - internal entry number
;FIELD - semicolon separated list of fields.
;These the are arguments for GETS^DIQ, see that documentation for
;more information.
;FDA and IENROOT are the FDA and IENROOT for UPDATE^DIE. These
;are already setup with the contents of the packed reminder before
;this routine is called.
N DIQOUT,IENS,IENSD,IENSF,IND,IND1,IND2,IND2S,IND3,FNUM,LE,MSG,MTABLE
N SITE,TIENROOT
S IENS=IEN_","
D GETS^DIQ(FILENUM,IENS,FIELD,"N","DIQOUT","MSG")
I $D(MSG) D Q
. N ETEXT,FILENAME
. S FILENAME=$$GET1^DID(FILENUM,"","","NAME")
. S ETEXT="In MOU^PXRMEXU5 GETS^DIQ failed for "_FILENAME_" entry "_IEN_", it returned the following error message:"
. W !,ETEXT
. D AWRITE^PXRMUTIL("MSG")
. H 2
;If there is nothing to merge quit.
I '$D(DIQOUT) Q
;Clean up DIQOUT remove null entries and change pointers to the resolved
;form.
D CLDIQOUT^PXRMEXPU(.DIQOUT)
D RMEH^PXRMEXPU(FILENUM,.DIQOUT,1)
;If there is nothing left to merge quit.
I '$D(DIQOUT) Q
;Build the merge table.
D BMTABLE(.MTABLE,.IENROOT,.DIQOUT,.FDA)
;Do the merge or update.
S FNUM=""
F S FNUM=$O(DIQOUT(FNUM)) Q:FNUM="" D
. S IENSD=""
. F S IENSD=$O(DIQOUT(FNUM,IENSD)) Q:IENSD="" D
.. S IENSF=MTABLE(FNUM,IENSD)
..;This is how update works for terms.
.. I (ACTION="U"),$D(FDA(FNUM,IENSF,.01)) Q
.. S FIELD=""
.. F S FIELD=$O(DIQOUT(FNUM,IENSD,FIELD)) Q:FIELD="" D
... I DIQOUT(FNUM,IENSD,FIELD)["WP-start" D WORDPROC(FNUM,IENSD,FIELD,.DIQOUT,.WPTMP)
... S FDA(FNUM,IENSF,FIELD)=DIQOUT(FNUM,IENSD,FIELD)
Q
;
;==================================================
MMTAB(MTABLE,IENROOT,LAST,FILENUM,IENS,IENRF) ;Generate a merge table entry.
N IENRL,FNUP,UP,UPIENS
S UP=$P(IENS,",",2,99)
;DBIA #2631
S FNUP=$G(^DD(FILENUM,0,"UP"))
S UPIENS=MTABLE(FNUP,UP)
S LAST=LAST+1
S MTABLE(FILENUM,IENS)="+"_LAST_","_UPIENS
S IENRL=$O(IENRF(FILENUM,""),-1)+1
S IENROOT(LAST)=IENRL,IENRF(FILENUM,IENRL)=LAST
Q
;
;==================================================
REPCHAR(PXRMRIEN,CHAR1,CHAR2) ;Replace CHAR1 with CHAR2 for all lines in node
;100 of entry PXRMRIEN of the Exchange File.
N IND,LINE
S IND=0
F S IND=+$O(^PXD(811.8,PXRMRIEN,100,IND)) Q:IND=0 D
. S LINE=$TR(^PXD(811.8,PXRMRIEN,100,IND,0),CHAR1,CHAR2)
. S ^PXD(811.8,PXRMRIEN,100,IND,0)=LINE
Q
;
;==================================================
ROC(FDA) ;For Reminder Order Checks.
N ACTION,IEN,IENS,OI,OOI,TEXT
S ACTION="",IENS=""
F S IENS=$O(FDA(801.02,IENS)) Q:IENS="" D I ACTION="Q" K FDA S PXRMDONE=1
.S TEXT=""
.S (OI,OOI)=FDA(801.02,IENS,.01)
.S IEN=$$EXISTS^PXRMEXIU(101.43,OI)
.I IEN>0,$G(^ORD(101.43,IEN,.1))'="" D
..S IEN=0
..S TEXT="ORDERABLE ITEM entry "_OI_" is inactive."
.I IEN=0 D
..;Get replacement
..I TEXT="" S TEXT="ORDERABLE ITEM entry "_OI_" does not exist."
..N DIC,DIR,DUOUT,MSG,X,Y
..S MSG(1)=" "
..S MSG(2)=TEXT
..D MES^XPDUTL(.MSG)
..S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR) I ACTION="S" S ACTION="Q"
..I ACTION="Q" Q
..I ACTION="D" K FDA(801.02,IENS,.01) Q
..S DIC=101.43
..S DIC(0)="AEMNQ"
..S Y=-1
..F Q:+Y'=-1 D
...;If this is being called during a KIDS install we need echoing on.
...I $D(XPDNM) X ^%ZOSF("EON")
...D ^DIC
...I $D(XPDNM) X ^%ZOSF("EOFF")
...;If this is being called during a KIDS install we need echoing on.
...I $D(DUOUT) S Y="" Q
...I Y=-1 D BMES^XPDUTL("You must input a replacement!")
..I Y="" S ACTION="Q" Q
..S OI=$P(Y,U,2)
..S FDA(801.02,IENS,.01)=OI
Q
;
;==================================================
ROCR(FDA) ;
N IENS
S IENS="" F S IENS=$O(FDA(801.1,IENS)) Q:IENS="" D
.I '$G(PXRMINST) S FDA(801.1,IENS,2)="I"
Q
;
;==================================================
TIU(IEN,ARRAY,SUB) ;
I $D(^TMP($J,SUB,IEN))>0 Q
N CNT,ERROR,OUTPUT
S OUTPUT=$NA(^TMP($J,SUB,IEN))
I $G(ARRAY(IEN,9))="" Q
S CNT=1 S @OUTPUT@(CNT)="TIU Object: "_$G(ARRAY(IEN,.01))
S CNT=CNT+1,@OUTPUT@(CNT)="Object Method: "_$G(ARRAY(IEN,9))
S CNT=CNT+1,@OUTPUT@(CNT)=""
Q
;
;==================================================
WORDPROC(FILENUM,IENSD,FIELD,DIQOUT,WPTMP) ;
N I3,NL
S NL=$P(DIQOUT(FILENUM,IENSD,FIELD),"~",2)
F I3=1:1:NL S WPTMP(FILENUM,+FIELD,I3)=DIQOUT(FILENUM,IENSD,FIELD,I3)
S DIQOUT(FILENUM,IENSD,FIELD)="WPTMP("_FILENUM_","_+FIELD_")"
Q
;
PXRMEXU5 ;SLC/PKR - Reminder exchange KIDS utilities, #5. ;06/03/2012
+1 ;;2.0;CLINICAL REMINDERS;**12,16,18,22**;Feb 04, 2005;Build 160
+2 ;==================================================
BMTABLE(MTABLE,IENROOT,DIQOUT,FDA) ;Build the table for merging
+1 ;GETS^DIQOUT indexes into the FDA. The merge table has the form:
+2 ;MTABLE(IENSD)=IENSF. IENSD is the DIQOUT iens and IENSF is the
+3 ;FDA iens. MTABLE provides a direct replacement of IENSD to IENSF.
+4 NEW FILENUM,IEN,IENS,IENSD,IENRF,IENSF,IND,LAST,LEN,NULLF,TOPFN
+5 SET FILENUM=$ORDER(FDA(""),-1)
SET IENS=$ORDER(FDA(FILENUM,""),-1)
+6 SET LAST=+$PIECE(IENS,",",1)
+7 ;Initialize the merge table by looking for identical entries in
+8 ;DIQOUT and FDA. First create the top level entry.
+9 SET NULLF=0
+10 SET FILENUM=$ORDER(DIQOUT(""))
+11 SET IENSD=$ORDER(DIQOUT(FILENUM,""))
+12 SET LEN=$LENGTH(IENSD,",")-1
+13 SET IENS=$PIECE(IENSD,",",LEN)_","
+14 ;DBIA #2631
+15 FOR IND=1:1:LEN-1
SET FILENUM=$GET(^DD(FILENUM,0,"UP"))
+16 SET TOPFN=FILENUM
+17 SET IENSF=$ORDER(FDA(TOPFN,""))
+18 SET MTABLE(TOPFN,IENS)=IENSF
+19 ;Build all the entries below the top level.
+20 SET FILENUM=TOPFN
+21 FOR
SET FILENUM=$ORDER(DIQOUT(FILENUM))
IF FILENUM=""
QUIT
Begin DoDot:1
+22 SET IENSD=""
+23 FOR
SET IENSD=$ORDER(DIQOUT(FILENUM,IENSD))
IF IENSD=""
QUIT
Begin DoDot:2
+24 SET MTABLE(FILENUM,IENSD)=""
+25 IF '$DATA(FDA(FILENUM))
SET NULLF=1
QUIT
+26 ;Look for matches based on identical .01s
+27 SET IENSF=""
+28 FOR
SET IENSF=$ORDER(FDA(FILENUM,IENSF))
IF IENSF=""
QUIT
Begin DoDot:3
+29 IF $GET(DIQOUT(FILENUM,IENSD,.01))=$GET(FDA(FILENUM,IENSF,.01))
SET MTABLE(FILENUM,IENSD)=IENSF
+30 IF '$TEST
SET NULLF=1
End DoDot:3
End DoDot:2
End DoDot:1
+31 ;Entries that are equal to null at this point don't have a
+32 ;corresponding FDA entry.
+33 IF 'NULLF
QUIT
+34 SET FILENUM=""
+35 FOR
SET FILENUM=$ORDER(FDA(FILENUM))
IF FILENUM=""
QUIT
Begin DoDot:1
+36 SET IENSF=""
+37 FOR
SET IENSF=$ORDER(FDA(FILENUM,IENSF))
IF IENSF=""
QUIT
Begin DoDot:2
+38 SET IND=+IENSF
+39 IF IENROOT(IND)'=""
SET IENRF(FILENUM,IENROOT(IND))=IND
End DoDot:2
End DoDot:1
+40 ;IENRF keeps track of the IENROOT entries by file number.
+41 SET FILENUM=""
+42 FOR
SET FILENUM=$ORDER(MTABLE(FILENUM))
IF FILENUM=""
QUIT
Begin DoDot:1
+43 SET IENSD=""
+44 FOR
SET IENSD=$ORDER(MTABLE(FILENUM,IENSD))
IF IENSD=""
QUIT
Begin DoDot:2
+45 IF MTABLE(FILENUM,IENSD)'=""
QUIT
+46 DO MMTAB(.MTABLE,.IENROOT,.LAST,FILENUM,IENSD,.IENRF)
End DoDot:2
End DoDot:1
+47 QUIT
+48 ;
+49 ;==================================================
LOIEN(FILENUM,START) ;Find the first open IEN in a global. If the optional
+1 ;parameter START is present then start there looking for the first
+2 ;open IEN.
+3 NEW GBL,I1,I2,OIEN
+4 SET GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")_"I1)"
+5 SET OIEN=-1
+6 SET (I1,I2)=0
+7 SET (I1,I2)=$SELECT($GET(START)>0:START,1:0)
+8 FOR
SET I1=+$ORDER(@GBL)
IF (OIEN>0)!(I1=0)
QUIT
Begin DoDot:1
+9 IF ((I1-I2)>1)!(I1="")
SET OIEN=I2+1
QUIT
+10 SET I2=I1
End DoDot:1
+11 IF OIEN=-1
SET OIEN=I2+1
+12 QUIT OIEN
+13 ;
+14 ;==================================================
MOU(FILENUM,IEN,FIELD,FDA,IENROOT,ACTION,WPTMP) ;Merge or update existing site
+1 ;entries into the FDA that is loaded from Exchange.
+2 ;FILENUM - the file number
+3 ;IEN - internal entry number
+4 ;FIELD - semicolon separated list of fields.
+5 ;These the are arguments for GETS^DIQ, see that documentation for
+6 ;more information.
+7 ;FDA and IENROOT are the FDA and IENROOT for UPDATE^DIE. These
+8 ;are already setup with the contents of the packed reminder before
+9 ;this routine is called.
+10 NEW DIQOUT,IENS,IENSD,IENSF,IND,IND1,IND2,IND2S,IND3,FNUM,LE,MSG,MTABLE
+11 NEW SITE,TIENROOT
+12 SET IENS=IEN_","
+13 DO GETS^DIQ(FILENUM,IENS,FIELD,"N","DIQOUT","MSG")
+14 IF $DATA(MSG)
Begin DoDot:1
+15 NEW ETEXT,FILENAME
+16 SET FILENAME=$$GET1^DID(FILENUM,"","","NAME")
+17 SET ETEXT="In MOU^PXRMEXU5 GETS^DIQ failed for "_FILENAME_" entry "_IEN_", it returned the following error message:"
+18 WRITE !,ETEXT
+19 DO AWRITE^PXRMUTIL("MSG")
+20 HANG 2
End DoDot:1
QUIT
+21 ;If there is nothing to merge quit.
+22 IF '$DATA(DIQOUT)
QUIT
+23 ;Clean up DIQOUT remove null entries and change pointers to the resolved
+24 ;form.
+25 DO CLDIQOUT^PXRMEXPU(.DIQOUT)
+26 DO RMEH^PXRMEXPU(FILENUM,.DIQOUT,1)
+27 ;If there is nothing left to merge quit.
+28 IF '$DATA(DIQOUT)
QUIT
+29 ;Build the merge table.
+30 DO BMTABLE(.MTABLE,.IENROOT,.DIQOUT,.FDA)
+31 ;Do the merge or update.
+32 SET FNUM=""
+33 FOR
SET FNUM=$ORDER(DIQOUT(FNUM))
IF FNUM=""
QUIT
Begin DoDot:1
+34 SET IENSD=""
+35 FOR
SET IENSD=$ORDER(DIQOUT(FNUM,IENSD))
IF IENSD=""
QUIT
Begin DoDot:2
+36 SET IENSF=MTABLE(FNUM,IENSD)
+37 ;This is how update works for terms.
+38 IF (ACTION="U")
IF $DATA(FDA(FNUM,IENSF,.01))
QUIT
+39 SET FIELD=""
+40 FOR
SET FIELD=$ORDER(DIQOUT(FNUM,IENSD,FIELD))
IF FIELD=""
QUIT
Begin DoDot:3
+41 IF DIQOUT(FNUM,IENSD,FIELD)["WP-start"
DO WORDPROC(FNUM,IENSD,FIELD,.DIQOUT,.WPTMP)
+42 SET FDA(FNUM,IENSF,FIELD)=DIQOUT(FNUM,IENSD,FIELD)
End DoDot:3
End DoDot:2
End DoDot:1
+43 QUIT
+44 ;
+45 ;==================================================
MMTAB(MTABLE,IENROOT,LAST,FILENUM,IENS,IENRF) ;Generate a merge table entry.
+1 NEW IENRL,FNUP,UP,UPIENS
+2 SET UP=$PIECE(IENS,",",2,99)
+3 ;DBIA #2631
+4 SET FNUP=$GET(^DD(FILENUM,0,"UP"))
+5 SET UPIENS=MTABLE(FNUP,UP)
+6 SET LAST=LAST+1
+7 SET MTABLE(FILENUM,IENS)="+"_LAST_","_UPIENS
+8 SET IENRL=$ORDER(IENRF(FILENUM,""),-1)+1
+9 SET IENROOT(LAST)=IENRL
SET IENRF(FILENUM,IENRL)=LAST
+10 QUIT
+11 ;
+12 ;==================================================
REPCHAR(PXRMRIEN,CHAR1,CHAR2) ;Replace CHAR1 with CHAR2 for all lines in node
+1 ;100 of entry PXRMRIEN of the Exchange File.
+2 NEW IND,LINE
+3 SET IND=0
+4 FOR
SET IND=+$ORDER(^PXD(811.8,PXRMRIEN,100,IND))
IF IND=0
QUIT
Begin DoDot:1
+5 SET LINE=$TRANSLATE(^PXD(811.8,PXRMRIEN,100,IND,0),CHAR1,CHAR2)
+6 SET ^PXD(811.8,PXRMRIEN,100,IND,0)=LINE
End DoDot:1
+7 QUIT
+8 ;
+9 ;==================================================
ROC(FDA) ;For Reminder Order Checks.
+1 NEW ACTION,IEN,IENS,OI,OOI,TEXT
+2 SET ACTION=""
SET IENS=""
+3 FOR
SET IENS=$ORDER(FDA(801.02,IENS))
IF IENS=""
QUIT
Begin DoDot:1
+4 SET TEXT=""
+5 SET (OI,OOI)=FDA(801.02,IENS,.01)
+6 SET IEN=$$EXISTS^PXRMEXIU(101.43,OI)
+7 IF IEN>0
IF $GET(^ORD(101.43,IEN,.1))'=""
Begin DoDot:2
+8 SET IEN=0
+9 SET TEXT="ORDERABLE ITEM entry "_OI_" is inactive."
End DoDot:2
+10 IF IEN=0
Begin DoDot:2
+11 ;Get replacement
+12 IF TEXT=""
SET TEXT="ORDERABLE ITEM entry "_OI_" does not exist."
+13 NEW DIC,DIR,DUOUT,MSG,X,Y
+14 SET MSG(1)=" "
+15 SET MSG(2)=TEXT
+16 DO MES^XPDUTL(.MSG)
+17 SET ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
IF ACTION="S"
SET ACTION="Q"
+18 IF ACTION="Q"
QUIT
+19 IF ACTION="D"
KILL FDA(801.02,IENS,.01)
QUIT
+20 SET DIC=101.43
+21 SET DIC(0)="AEMNQ"
+22 SET Y=-1
+23 FOR
IF +Y'=-1
QUIT
Begin DoDot:3
+24 ;If this is being called during a KIDS install we need echoing on.
+25 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EON")
+26 DO ^DIC
+27 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EOFF")
+28 ;If this is being called during a KIDS install we need echoing on.
+29 IF $DATA(DUOUT)
SET Y=""
QUIT
+30 IF Y=-1
DO BMES^XPDUTL("You must input a replacement!")
End DoDot:3
+31 IF Y=""
SET ACTION="Q"
QUIT
+32 SET OI=$PIECE(Y,U,2)
+33 SET FDA(801.02,IENS,.01)=OI
End DoDot:2
End DoDot:1
IF ACTION="Q"
KILL FDA
SET PXRMDONE=1
+34 QUIT
+35 ;
+36 ;==================================================
ROCR(FDA) ;
+1 NEW IENS
+2 SET IENS=""
FOR
SET IENS=$ORDER(FDA(801.1,IENS))
IF IENS=""
QUIT
Begin DoDot:1
+3 IF '$GET(PXRMINST)
SET FDA(801.1,IENS,2)="I"
End DoDot:1
+4 QUIT
+5 ;
+6 ;==================================================
TIU(IEN,ARRAY,SUB) ;
+1 IF $DATA(^TMP($JOB,SUB,IEN))>0
QUIT
+2 NEW CNT,ERROR,OUTPUT
+3 SET OUTPUT=$NAME(^TMP($JOB,SUB,IEN))
+4 IF $GET(ARRAY(IEN,9))=""
QUIT
+5 SET CNT=1
SET @OUTPUT@(CNT)="TIU Object: "_$GET(ARRAY(IEN,.01))
+6 SET CNT=CNT+1
SET @OUTPUT@(CNT)="Object Method: "_$GET(ARRAY(IEN,9))
+7 SET CNT=CNT+1
SET @OUTPUT@(CNT)=""
+8 QUIT
+9 ;
+10 ;==================================================
WORDPROC(FILENUM,IENSD,FIELD,DIQOUT,WPTMP) ;
+1 NEW I3,NL
+2 SET NL=$PIECE(DIQOUT(FILENUM,IENSD,FIELD),"~",2)
+3 FOR I3=1:1:NL
SET WPTMP(FILENUM,+FIELD,I3)=DIQOUT(FILENUM,IENSD,FIELD,I3)
+4 SET DIQOUT(FILENUM,IENSD,FIELD)="WPTMP("_FILENUM_","_+FIELD_")"
+5 QUIT
+6 ;
