Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXRMEXU5

PXRMEXU5.m

Go to the documentation of this file. 
  1. 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
  1.  ;==================================================
  1. BMTABLE(MTABLE,IENROOT,DIQOUT,FDA) ;Build the table for merging
  1.  ;GETS^DIQOUT indexes into the FDA. The merge table has the form:
  1.  ;MTABLE(IENSD)=IENSF. IENSD is the DIQOUT iens and IENSF is the
  1.  ;FDA iens. MTABLE provides a direct replacement of IENSD to IENSF.
  1.  N FILENUM,IEN,IENS,IENSD,IENRF,IENSF,IND,LAST,LEN,NULLF,TOPFN
  1.  S FILENUM=$O(FDA(""),-1),IENS=$O(FDA(FILENUM,""),-1)
  1.  S LAST=+$P(IENS,",",1)
  1.  ;Initialize the merge table by looking for identical entries in
  1.  ;DIQOUT and FDA. First create the top level entry.
  1.  S NULLF=0
  1.  S FILENUM=$O(DIQOUT(""))
  1.  S IENSD=$O(DIQOUT(FILENUM,""))
  1.  S LEN=$L(IENSD,",")-1
  1.  S IENS=$P(IENSD,",",LEN)_","
  1.  ;DBIA #2631
  1.  F IND=1:1:LEN-1 S FILENUM=$G(^DD(FILENUM,0,"UP"))
  1.  S TOPFN=FILENUM
  1.  S IENSF=$O(FDA(TOPFN,""))
  1.  S MTABLE(TOPFN,IENS)=IENSF
  1.  ;Build all the entries below the top level.
  1.  S FILENUM=TOPFN
  1.  F  S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM=""  D
  1.  . S IENSD=""
  1.  . F  S IENSD=$O(DIQOUT(FILENUM,IENSD)) Q:IENSD=""  D
  1.  .. S MTABLE(FILENUM,IENSD)=""
  1.  .. I '$D(FDA(FILENUM)) S NULLF=1 Q
  1.  ..;Look for matches based on identical .01s
  1.  .. S IENSF=""
  1.  .. F  S IENSF=$O(FDA(FILENUM,IENSF)) Q:IENSF=""  D
  1.  ... I $G(DIQOUT(FILENUM,IENSD,.01))=$G(FDA(FILENUM,IENSF,.01)) S MTABLE(FILENUM,IENSD)=IENSF
  1.  ... E  S NULLF=1
  1.  ;Entries that are equal to null at this point don't have a
  1.  ;corresponding FDA entry.
  1.  I 'NULLF Q
  1.  S FILENUM=""
  1.  F  S FILENUM=$O(FDA(FILENUM)) Q:FILENUM=""  D
  1.  . S IENSF=""
  1.  . F  S IENSF=$O(FDA(FILENUM,IENSF)) Q:IENSF=""  D
  1.  .. S IND=+IENSF
  1.  .. I IENROOT(IND)'="" S IENRF(FILENUM,IENROOT(IND))=IND
  1.  ;IENRF keeps track of the IENROOT entries by file number.
  1.  S FILENUM=""
  1.  F  S FILENUM=$O(MTABLE(FILENUM)) Q:FILENUM=""  D
  1.  . S IENSD=""
  1.  . F  S IENSD=$O(MTABLE(FILENUM,IENSD)) Q:IENSD=""  D
  1.  .. I MTABLE(FILENUM,IENSD)'="" Q
  1.  .. D MMTAB(.MTABLE,.IENROOT,.LAST,FILENUM,IENSD,.IENRF)
  1.  Q
  1.  ;
  1.  ;==================================================
  1. 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
  1.  ;open IEN.
  1.  N GBL,I1,I2,OIEN
  1.  S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")_"I1)"
  1.  S OIEN=-1
  1.  S (I1,I2)=0
  1.  S (I1,I2)=$S($G(START)>0:START,1:0)
  1.  F  S I1=+$O(@GBL) Q:(OIEN>0)!(I1=0)  D
  1.  . I ((I1-I2)>1)!(I1="") S OIEN=I2+1 Q
  1.  . S I2=I1
  1.  I OIEN=-1 S OIEN=I2+1
  1.  Q OIEN
  1.  ;
  1.  ;==================================================
  1. MOU(FILENUM,IEN,FIELD,FDA,IENROOT,ACTION,WPTMP) ;Merge or update existing site
  1.  ;entries into the FDA that is loaded from Exchange.
  1.  ;FILENUM - the file number
  1.  ;IEN - internal entry number
  1.  ;FIELD - semicolon separated list of fields.
  1.  ;These the are arguments for GETS^DIQ, see that documentation for 
  1.  ;more information.
  1.  ;FDA and IENROOT are the FDA and IENROOT for UPDATE^DIE. These
  1.  ;are already setup with the contents of the packed reminder before
  1.  ;this routine is called.
  1.  N DIQOUT,IENS,IENSD,IENSF,IND,IND1,IND2,IND2S,IND3,FNUM,LE,MSG,MTABLE
  1.  N SITE,TIENROOT
  1.  S IENS=IEN_","
  1.  D GETS^DIQ(FILENUM,IENS,FIELD,"N","DIQOUT","MSG")
  1.  I $D(MSG) D  Q
  1.  . N ETEXT,FILENAME
  1.  . S FILENAME=$$GET1^DID(FILENUM,"","","NAME")
  1.  . S ETEXT="In MOU^PXRMEXU5 GETS^DIQ failed for "_FILENAME_" entry "_IEN_", it returned the following error message:"
  1.  . W !,ETEXT
  1.  . D AWRITE^PXRMUTIL("MSG")
  1.  . H 2
  1.  ;If there is nothing to merge quit.
  1.  I '$D(DIQOUT) Q
  1.  ;Clean up DIQOUT remove null entries and change pointers to the resolved
  1.  ;form.
  1.  D CLDIQOUT^PXRMEXPU(.DIQOUT)
  1.  D RMEH^PXRMEXPU(FILENUM,.DIQOUT,1)
  1.  ;If there is nothing left to merge quit.
  1.  I '$D(DIQOUT) Q
  1.  ;Build the merge table.
  1.  D BMTABLE(.MTABLE,.IENROOT,.DIQOUT,.FDA)
  1.  ;Do the merge or update.
  1.  S FNUM=""
  1.  F  S FNUM=$O(DIQOUT(FNUM)) Q:FNUM=""  D
  1.  . S IENSD=""
  1.  . F  S IENSD=$O(DIQOUT(FNUM,IENSD)) Q:IENSD=""  D
  1.  .. S IENSF=MTABLE(FNUM,IENSD)
  1.  ..;This is how update works for terms.
  1.  .. I (ACTION="U"),$D(FDA(FNUM,IENSF,.01)) Q
  1.  .. S FIELD=""
  1.  .. F  S FIELD=$O(DIQOUT(FNUM,IENSD,FIELD)) Q:FIELD=""  D
  1.  ... I DIQOUT(FNUM,IENSD,FIELD)["WP-start" D WORDPROC(FNUM,IENSD,FIELD,.DIQOUT,.WPTMP)
  1.  ... S FDA(FNUM,IENSF,FIELD)=DIQOUT(FNUM,IENSD,FIELD)
  1.  Q
  1.  ;
  1.  ;==================================================
  1. MMTAB(MTABLE,IENROOT,LAST,FILENUM,IENS,IENRF) ;Generate a merge table entry.
  1.  N IENRL,FNUP,UP,UPIENS
  1.  S UP=$P(IENS,",",2,99)
  1.  ;DBIA #2631
  1.  S FNUP=$G(^DD(FILENUM,0,"UP"))
  1.  S UPIENS=MTABLE(FNUP,UP)
  1.  S LAST=LAST+1
  1.  S MTABLE(FILENUM,IENS)="+"_LAST_","_UPIENS
  1.  S IENRL=$O(IENRF(FILENUM,""),-1)+1
  1.  S IENROOT(LAST)=IENRL,IENRF(FILENUM,IENRL)=LAST
  1.  Q
  1.  ;
  1.  ;==================================================
  1. REPCHAR(PXRMRIEN,CHAR1,CHAR2) ;Replace CHAR1 with CHAR2 for all lines in node
  1.  ;100 of entry PXRMRIEN of the Exchange File.
  1.  N IND,LINE
  1.  S IND=0
  1.  F  S IND=+$O(^PXD(811.8,PXRMRIEN,100,IND)) Q:IND=0  D
  1.  . S LINE=$TR(^PXD(811.8,PXRMRIEN,100,IND,0),CHAR1,CHAR2)
  1.  . S ^PXD(811.8,PXRMRIEN,100,IND,0)=LINE
  1.  Q
  1.  ;
  1.  ;==================================================
  1. ROC(FDA) ;For Reminder Order Checks.
  1.  N ACTION,IEN,IENS,OI,OOI,TEXT
  1.  S ACTION="",IENS=""
  1.  F  S IENS=$O(FDA(801.02,IENS)) Q:IENS=""  D  I ACTION="Q" K FDA S PXRMDONE=1
  1.  .S TEXT=""
  1.  .S (OI,OOI)=FDA(801.02,IENS,.01)
  1.  .S IEN=$$EXISTS^PXRMEXIU(101.43,OI)
  1.  .I IEN>0,$G(^ORD(101.43,IEN,.1))'="" D
  1.  ..S IEN=0
  1.  ..S TEXT="ORDERABLE ITEM  entry "_OI_" is inactive."
  1.  .I IEN=0 D
  1.  ..;Get replacement
  1.  ..I TEXT="" S TEXT="ORDERABLE ITEM  entry "_OI_" does not exist."
  1.  ..N DIC,DIR,DUOUT,MSG,X,Y
  1.  ..S MSG(1)=" "
  1.  ..S MSG(2)=TEXT
  1.  ..D MES^XPDUTL(.MSG)
  1.  ..S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR) I ACTION="S" S ACTION="Q"
  1.  ..I ACTION="Q" Q
  1.  ..I ACTION="D" K FDA(801.02,IENS,.01) Q
  1.  ..S DIC=101.43
  1.  ..S DIC(0)="AEMNQ"
  1.  ..S Y=-1
  1.  ..F  Q:+Y'=-1  D
  1.  ...;If this is being called during a KIDS install we need echoing on.
  1.  ...I $D(XPDNM) X ^%ZOSF("EON")
  1.  ...D ^DIC
  1.  ...I $D(XPDNM) X ^%ZOSF("EOFF")
  1.  ...;If this is being called during a KIDS install we need echoing on.
  1.  ...I $D(DUOUT) S Y="" Q
  1.  ...I Y=-1 D BMES^XPDUTL("You must input a replacement!")
  1.  ..I Y="" S ACTION="Q" Q
  1.  ..S OI=$P(Y,U,2)
  1.  ..S FDA(801.02,IENS,.01)=OI
  1.  Q
  1.  ;
  1.  ;==================================================
  1. ROCR(FDA) ;
  1.  N IENS
  1.  S IENS="" F  S IENS=$O(FDA(801.1,IENS)) Q:IENS=""  D
  1.  .I '$G(PXRMINST) S FDA(801.1,IENS,2)="I"
  1.  Q
  1.  ;
  1.  ;==================================================
  1. TIU(IEN,ARRAY,SUB) ;
  1.  I $D(^TMP($J,SUB,IEN))>0 Q
  1.  N CNT,ERROR,OUTPUT
  1.  S OUTPUT=$NA(^TMP($J,SUB,IEN))
  1.  I $G(ARRAY(IEN,9))="" Q
  1.  S CNT=1 S @OUTPUT@(CNT)="TIU Object: "_$G(ARRAY(IEN,.01))
  1.  S CNT=CNT+1,@OUTPUT@(CNT)="Object Method: "_$G(ARRAY(IEN,9))
  1.  S CNT=CNT+1,@OUTPUT@(CNT)=""
  1.  Q
  1.  ;
  1.  ;==================================================
  1. WORDPROC(FILENUM,IENSD,FIELD,DIQOUT,WPTMP) ;
  1.  N I3,NL
  1.  S NL=$P(DIQOUT(FILENUM,IENSD,FIELD),"~",2)
  1.  F I3=1:1:NL S WPTMP(FILENUM,+FIELD,I3)=DIQOUT(FILENUM,IENSD,FIELD,I3)
  1.  S DIQOUT(FILENUM,IENSD,FIELD)="WPTMP("_FILENUM_","_+FIELD_")"
  1.  Q
  1.  ;