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. ;07/16/2020
  1. ;;2.0;CLINICAL REMINDERS;**12,16,18,22,45,42**;Feb 04, 2005;Build 245
  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. DIALOGGF(FDA,IENROOT) ;
  1. N FOUND,IEN,LIEN,NAME,PKGIEN,PREFIX,TEMP
  1. S IENS="" F S IENS=$O(FDA(801.46,IENS)) Q:IENS="" D
  1. .S TEMP=$G(FDA(801.46,IENS,2)) I TEMP="" Q
  1. .S NAME=$P(TEMP,U),PREFIX=$P(TEMP,U,2)
  1. .I NAME=""!(PREFIX="") Q
  1. .S FOUND=0,LIEN=0
  1. .S IEN=0 F S IEN=$O(^DIC(9.4,"B",NAME,IEN)) Q:IEN'>0!(FOUND=1) D
  1. ..I $D(^DIC(9.4,"C",PREFIX,IEN)) S LIEN=IEN,FOUND=1 Q
  1. .I LIEN'>0 Q
  1. .S FDA(801.46,IENS,2)="`"_LIEN
  1. Q
  1. ;
  1. ;=============
  1. DLINKSAV(FDA) ; save dialog entry to temp global to prevent recurrisve install.
  1. N EXIST,IENS,DIAL,NAME
  1. S IENS="" F S IENS=$O(FDA(801.48,IENS)) Q:IENS="" D
  1. .S NAME=FDA(801.48,IENS,.01)
  1. .S DIAL=FDA(801.48,IENS,1)
  1. .S EXIST=$$EXISTS^PXRMEXIU(801.41,DIAL,"") I +EXIST>0 Q
  1. .S ^TMP("PXRM DIALOG LINK FILE",$J,NAME)=DIAL
  1. .K FDA(801.48,IENS,1)
  1. Q
  1. ;
  1. ;=============
  1. DLINKSET ; reset file dialog entry to link file
  1. N DA,DIE,DIEN,DIK,DNAME,DR,LIEN,LNAME
  1. S LNAME="" F S LNAME=$O(^TMP("PXRM DIALOG LINK FILE",$J,LNAME)) Q:LNAME="" D
  1. .S LIEN=$$EXISTS^PXRMEXIU(801.48,LNAME,"") I +LIEN'>0 Q
  1. .S DNAME=$G(^TMP("PXRM DIALOG LINK FILE",$J,LNAME)) I DNAME="" Q
  1. .S DIEN=$$EXISTS^PXRMEXIU(801.41,DNAME,"") I +DIEN'>0 Q
  1. .;Set link type to dialog pointer.
  1. .S DR="1///^S X=DNAME",DIE="^PXRMD(801.48,",DA=LIEN
  1. .D ^DIE
  1. Q
  1. ;
  1. ;=============
  1. EXCHINCK(EXNAME,DPACKED) ;Given the name and the date packed of an Exchange
  1. ;entry return:
  1. ; -1 if the entry does not exist
  1. ; 0 if it has never been installed
  1. ; 1^installation date/time
  1. I $G(EXNAME)="" Q -1
  1. I $G(DPACKED)="" Q -1
  1. N DTP,IEN,IND,LASTINDT
  1. D DT^DILF("ST",DPACKED,.DTP)
  1. S IEN=+$O(^PXD(811.8,"B",EXNAME,DTP,""))
  1. I IEN=0 Q -1
  1. S IND=+$O(^PXD(811.8,IEN,130,"B"),-1)
  1. I IND=0 Q 0
  1. S LASTINDT=$P(^PXD(811.8,IEN,130,IND,0),U,1)
  1. Q 1_U_LASTINDT
  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. 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. ;Make sure the IENROOT entries are unique.
  1. I $D(IENROOT(LAST)) S LAST=$O(IENROOT(""),-1)+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. 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. ;Remove the edit history.
  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. 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,IENROOT) ;For Reminder Order Checks.
  1. N ACTION,IEN,IENS,NODE,OI,OOI,TEXT
  1. S ACTION="",IENS=""
  1. I $D(FDA(801.02)) D ROCCONV(.FDA,.IENROOT) K FDA(801.02)
  1. F S IENS=$O(FDA(801.015,IENS)) Q:IENS="" D I ACTION="Q" K FDA S PXRMDONE=1
  1. .S NODE=FDA(801.015,IENS,.01) I NODE'["OI" Q
  1. .S TEXT=""
  1. .S (OI,OOI)=$P(NODE,".",2)
  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.015,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) K IEN
  1. ..S FDA(801.015,IENS,.01)=$P(NODE,"`")_"`"_OI
  1. .I IEN>0 S FDA(801.015,IENS,.01)="OI.`"_IEN
  1. Q
  1. ;
  1. ;=============
  1. ROCCONV(FDA,IENROOT) ;handle converting pre-patch 45 packed file to new structure
  1. N CNT,IEN,IENS,IEN1,IENL,LIST,OI,OIIEN
  1. ;build list of orderable items
  1. S IEN1=0
  1. S IENS="",IENL="" F S IENS=$O(FDA(801.02,IENS)) Q:IENS="" D
  1. .I $G(FDA(801.02,IENS,.01))="" Q
  1. .S OI=FDA(801.02,IENS,.01)
  1. .S OIIEN=$$FIND1^DIC(101.43,"","BXU",OI)
  1. .I +OIIEN'>0 D BMES^XPDUTL("Error mapping Orderable Item: "_OI_" to new file structure.") Q
  1. .S FDA(801.015,IENS,.01)="OI."_OI
  1. S IENS="",CNT=0 F S IENS=$O(FDA(801.015,IENS)) Q:IENS="" D
  1. .S CNT=CNT+1
  1. .I $G(FDA(801.015,IENS,.01))'["OI" Q
  1. .S IEN=+$P(IENS,",")
  1. .S IENROOT(IEN)=CNT
  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. ;