PXRMEXU5 ;SLC/PKR - Reminder exchange KIDS utilities, #5. ;07/16/2020
;;2.0;CLINICAL REMINDERS;**12,16,18,22,45,42**;Feb 04, 2005;Build 245
;=============
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
;
;=============
DIALOGGF(FDA,IENROOT) ;
N FOUND,IEN,LIEN,NAME,PKGIEN,PREFIX,TEMP
S IENS="" F S IENS=$O(FDA(801.46,IENS)) Q:IENS="" D
.S TEMP=$G(FDA(801.46,IENS,2)) I TEMP="" Q
.S NAME=$P(TEMP,U),PREFIX=$P(TEMP,U,2)
.I NAME=""!(PREFIX="") Q
.S FOUND=0,LIEN=0
.S IEN=0 F S IEN=$O(^DIC(9.4,"B",NAME,IEN)) Q:IEN'>0!(FOUND=1) D
..I $D(^DIC(9.4,"C",PREFIX,IEN)) S LIEN=IEN,FOUND=1 Q
.I LIEN'>0 Q
.S FDA(801.46,IENS,2)="`"_LIEN
Q
;
;=============
DLINKSAV(FDA) ; save dialog entry to temp global to prevent recurrisve install.
N EXIST,IENS,DIAL,NAME
S IENS="" F S IENS=$O(FDA(801.48,IENS)) Q:IENS="" D
.S NAME=FDA(801.48,IENS,.01)
.S DIAL=FDA(801.48,IENS,1)
.S EXIST=$$EXISTS^PXRMEXIU(801.41,DIAL,"") I +EXIST>0 Q
.S ^TMP("PXRM DIALOG LINK FILE",$J,NAME)=DIAL
.K FDA(801.48,IENS,1)
Q
;
;=============
DLINKSET ; reset file dialog entry to link file
N DA,DIE,DIEN,DIK,DNAME,DR,LIEN,LNAME
S LNAME="" F S LNAME=$O(^TMP("PXRM DIALOG LINK FILE",$J,LNAME)) Q:LNAME="" D
.S LIEN=$$EXISTS^PXRMEXIU(801.48,LNAME,"") I +LIEN'>0 Q
.S DNAME=$G(^TMP("PXRM DIALOG LINK FILE",$J,LNAME)) I DNAME="" Q
.S DIEN=$$EXISTS^PXRMEXIU(801.41,DNAME,"") I +DIEN'>0 Q
.;Set link type to dialog pointer.
.S DR="1///^S X=DNAME",DIE="^PXRMD(801.48,",DA=LIEN
.D ^DIE
Q
;
;=============
EXCHINCK(EXNAME,DPACKED) ;Given the name and the date packed of an Exchange
;entry return:
; -1 if the entry does not exist
; 0 if it has never been installed
; 1^installation date/time
I $G(EXNAME)="" Q -1
I $G(DPACKED)="" Q -1
N DTP,IEN,IND,LASTINDT
D DT^DILF("ST",DPACKED,.DTP)
S IEN=+$O(^PXD(811.8,"B",EXNAME,DTP,""))
I IEN=0 Q -1
S IND=+$O(^PXD(811.8,IEN,130,"B"),-1)
I IND=0 Q 0
S LASTINDT=$P(^PXD(811.8,IEN,130,IND,0),U,1)
Q 1_U_LASTINDT
;
;=============
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
;
;=============
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
;Make sure the IENROOT entries are unique.
I $D(IENROOT(LAST)) S LAST=$O(IENROOT(""),-1)+1
S MTABLE(FILENUM,IENS)="+"_LAST_","_UPIENS
S IENRL=$O(IENRF(FILENUM,""),-1)+1
S IENROOT(LAST)=IENRL,IENRF(FILENUM,IENRL)=LAST
Q
;
;=============
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)
;Remove the edit history.
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
;
;=============
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,IENROOT) ;For Reminder Order Checks.
N ACTION,IEN,IENS,NODE,OI,OOI,TEXT
S ACTION="",IENS=""
I $D(FDA(801.02)) D ROCCONV(.FDA,.IENROOT) K FDA(801.02)
F S IENS=$O(FDA(801.015,IENS)) Q:IENS="" D I ACTION="Q" K FDA S PXRMDONE=1
.S NODE=FDA(801.015,IENS,.01) I NODE'["OI" Q
.S TEXT=""
.S (OI,OOI)=$P(NODE,".",2)
.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.015,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) K IEN
..S FDA(801.015,IENS,.01)=$P(NODE,"`")_"`"_OI
.I IEN>0 S FDA(801.015,IENS,.01)="OI.`"_IEN
Q
;
;=============
ROCCONV(FDA,IENROOT) ;handle converting pre-patch 45 packed file to new structure
N CNT,IEN,IENS,IEN1,IENL,LIST,OI,OIIEN
;build list of orderable items
S IEN1=0
S IENS="",IENL="" F S IENS=$O(FDA(801.02,IENS)) Q:IENS="" D
.I $G(FDA(801.02,IENS,.01))="" Q
.S OI=FDA(801.02,IENS,.01)
.S OIIEN=$$FIND1^DIC(101.43,"","BXU",OI)
.I +OIIEN'>0 D BMES^XPDUTL("Error mapping Orderable Item: "_OI_" to new file structure.") Q
.S FDA(801.015,IENS,.01)="OI."_OI
S IENS="",CNT=0 F S IENS=$O(FDA(801.015,IENS)) Q:IENS="" D
.S CNT=CNT+1
.I $G(FDA(801.015,IENS,.01))'["OI" Q
.S IEN=+$P(IENS,",")
.S IENROOT(IEN)=CNT
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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMEXU5 9598 printed Oct 16, 2024@17:46:11 Page 2
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
+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 ;=============
DIALOGGF(FDA,IENROOT) ;
+1 NEW FOUND,IEN,LIEN,NAME,PKGIEN,PREFIX,TEMP
+2 SET IENS=""
FOR
SET IENS=$ORDER(FDA(801.46,IENS))
if IENS=""
QUIT
Begin DoDot:1
+3 SET TEMP=$GET(FDA(801.46,IENS,2))
IF TEMP=""
QUIT
+4 SET NAME=$PIECE(TEMP,U)
SET PREFIX=$PIECE(TEMP,U,2)
+5 IF NAME=""!(PREFIX="")
QUIT
+6 SET FOUND=0
SET LIEN=0
+7 SET IEN=0
FOR
SET IEN=$ORDER(^DIC(9.4,"B",NAME,IEN))
if IEN'>0!(FOUND=1)
QUIT
Begin DoDot:2
+8 IF $DATA(^DIC(9.4,"C",PREFIX,IEN))
SET LIEN=IEN
SET FOUND=1
QUIT
End DoDot:2
+9 IF LIEN'>0
QUIT
+10 SET FDA(801.46,IENS,2)="`"_LIEN
End DoDot:1
+11 QUIT
+12 ;
+13 ;=============
DLINKSAV(FDA) ; save dialog entry to temp global to prevent recurrisve install.
+1 NEW EXIST,IENS,DIAL,NAME
+2 SET IENS=""
FOR
SET IENS=$ORDER(FDA(801.48,IENS))
if IENS=""
QUIT
Begin DoDot:1
+3 SET NAME=FDA(801.48,IENS,.01)
+4 SET DIAL=FDA(801.48,IENS,1)
+5 SET EXIST=$$EXISTS^PXRMEXIU(801.41,DIAL,"")
IF +EXIST>0
QUIT
+6 SET ^TMP("PXRM DIALOG LINK FILE",$JOB,NAME)=DIAL
+7 KILL FDA(801.48,IENS,1)
End DoDot:1
+8 QUIT
+9 ;
+10 ;=============
DLINKSET ; reset file dialog entry to link file
+1 NEW DA,DIE,DIEN,DIK,DNAME,DR,LIEN,LNAME
+2 SET LNAME=""
FOR
SET LNAME=$ORDER(^TMP("PXRM DIALOG LINK FILE",$JOB,LNAME))
if LNAME=""
QUIT
Begin DoDot:1
+3 SET LIEN=$$EXISTS^PXRMEXIU(801.48,LNAME,"")
IF +LIEN'>0
QUIT
+4 SET DNAME=$GET(^TMP("PXRM DIALOG LINK FILE",$JOB,LNAME))
IF DNAME=""
QUIT
+5 SET DIEN=$$EXISTS^PXRMEXIU(801.41,DNAME,"")
IF +DIEN'>0
QUIT
+6 ;Set link type to dialog pointer.
+7 SET DR="1///^S X=DNAME"
SET DIE="^PXRMD(801.48,"
SET DA=LIEN
+8 DO ^DIE
End DoDot:1
+9 QUIT
+10 ;
+11 ;=============
EXCHINCK(EXNAME,DPACKED) ;Given the name and the date packed of an Exchange
+1 ;entry return:
+2 ; -1 if the entry does not exist
+3 ; 0 if it has never been installed
+4 ; 1^installation date/time
+5 IF $GET(EXNAME)=""
QUIT -1
+6 IF $GET(DPACKED)=""
QUIT -1
+7 NEW DTP,IEN,IND,LASTINDT
+8 DO DT^DILF("ST",DPACKED,.DTP)
+9 SET IEN=+$ORDER(^PXD(811.8,"B",EXNAME,DTP,""))
+10 IF IEN=0
QUIT -1
+11 SET IND=+$ORDER(^PXD(811.8,IEN,130,"B"),-1)
+12 IF IND=0
QUIT 0
+13 SET LASTINDT=$PIECE(^PXD(811.8,IEN,130,IND,0),U,1)
+14 QUIT 1_U_LASTINDT
+15 ;
+16 ;=============
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 ;=============
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 ;Make sure the IENROOT entries are unique.
+8 IF $DATA(IENROOT(LAST))
SET LAST=$ORDER(IENROOT(""),-1)+1
+9 SET MTABLE(FILENUM,IENS)="+"_LAST_","_UPIENS
+10 SET IENRL=$ORDER(IENRF(FILENUM,""),-1)+1
+11 SET IENROOT(LAST)=IENRL
SET IENRF(FILENUM,IENRL)=LAST
+12 QUIT
+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 ;Remove the edit history.
+27 DO RMEH^PXRMEXPU(FILENUM,.DIQOUT,1)
+28 ;If there is nothing left to merge quit.
+29 IF '$DATA(DIQOUT)
QUIT
+30 ;Build the merge table.
+31 DO BMTABLE(.MTABLE,.IENROOT,.DIQOUT,.FDA)
+32 ;Do the merge or update.
+33 SET FNUM=""
+34 FOR
SET FNUM=$ORDER(DIQOUT(FNUM))
if FNUM=""
QUIT
Begin DoDot:1
+35 SET IENSD=""
+36 FOR
SET IENSD=$ORDER(DIQOUT(FNUM,IENSD))
if IENSD=""
QUIT
Begin DoDot:2
+37 SET IENSF=MTABLE(FNUM,IENSD)
+38 ;This is how update works for terms.
+39 IF (ACTION="U")
IF $DATA(FDA(FNUM,IENSF,.01))
QUIT
+40 SET FIELD=""
+41 FOR
SET FIELD=$ORDER(DIQOUT(FNUM,IENSD,FIELD))
if FIELD=""
QUIT
Begin DoDot:3
+42 IF DIQOUT(FNUM,IENSD,FIELD)["WP-start"
DO WORDPROC(FNUM,IENSD,FIELD,.DIQOUT,.WPTMP)
+43 SET FDA(FNUM,IENSF,FIELD)=DIQOUT(FNUM,IENSD,FIELD)
End DoDot:3
End DoDot:2
End DoDot:1
+44 QUIT
+45 ;
+46 ;=============
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,IENROOT) ;For Reminder Order Checks.
+1 NEW ACTION,IEN,IENS,NODE,OI,OOI,TEXT
+2 SET ACTION=""
SET IENS=""
+3 IF $DATA(FDA(801.02))
DO ROCCONV(.FDA,.IENROOT)
KILL FDA(801.02)
+4 FOR
SET IENS=$ORDER(FDA(801.015,IENS))
if IENS=""
QUIT
Begin DoDot:1
+5 SET NODE=FDA(801.015,IENS,.01)
IF NODE'["OI"
QUIT
+6 SET TEXT=""
+7 SET (OI,OOI)=$PIECE(NODE,".",2)
+8 SET IEN=$$EXISTS^PXRMEXIU(101.43,OI)
+9 IF IEN>0
IF $GET(^ORD(101.43,IEN,.1))'=""
Begin DoDot:2
+10 SET IEN=0
+11 SET TEXT="ORDERABLE ITEM entry "_OI_" is inactive."
End DoDot:2
+12 IF IEN=0
Begin DoDot:2
+13 ;Get replacement
+14 IF TEXT=""
SET TEXT="ORDERABLE ITEM entry "_OI_" does not exist."
+15 NEW DIC,DIR,DUOUT,MSG,X,Y
+16 SET MSG(1)=" "
+17 SET MSG(2)=TEXT
+18 DO MES^XPDUTL(.MSG)
+19 SET ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
IF ACTION="S"
SET ACTION="Q"
+20 IF ACTION="Q"
QUIT
+21 IF ACTION="D"
KILL FDA(801.015,IENS,.01)
QUIT
+22 SET DIC=101.43
+23 SET DIC(0)="AEMNQ"
+24 SET Y=-1
+25 FOR
if +Y'=-1
QUIT
Begin DoDot:3
+26 ;If this is being called during a KIDS install we need echoing on.
+27 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EON")
+28 DO ^DIC
+29 IF $DATA(XPDNM)
XECUTE ^%ZOSF("EOFF")
+30 ;If this is being called during a KIDS install we need echoing on.
+31 IF $DATA(DUOUT)
SET Y=""
QUIT
+32 IF Y=-1
DO BMES^XPDUTL("You must input a replacement!")
End DoDot:3
+33 IF Y=""
SET ACTION="Q"
QUIT
+34 SET OI=$PIECE(Y,U,2)
KILL IEN
+35 SET FDA(801.015,IENS,.01)=$PIECE(NODE,"`")_"`"_OI
End DoDot:2
+36 IF IEN>0
SET FDA(801.015,IENS,.01)="OI.`"_IEN
End DoDot:1
IF ACTION="Q"
KILL FDA
SET PXRMDONE=1
+37 QUIT
+38 ;
+39 ;=============
ROCCONV(FDA,IENROOT) ;handle converting pre-patch 45 packed file to new structure
+1 NEW CNT,IEN,IENS,IEN1,IENL,LIST,OI,OIIEN
+2 ;build list of orderable items
+3 SET IEN1=0
+4 SET IENS=""
SET IENL=""
FOR
SET IENS=$ORDER(FDA(801.02,IENS))
if IENS=""
QUIT
Begin DoDot:1
+5 IF $GET(FDA(801.02,IENS,.01))=""
QUIT
+6 SET OI=FDA(801.02,IENS,.01)
+7 SET OIIEN=$$FIND1^DIC(101.43,"","BXU",OI)
+8 IF +OIIEN'>0
DO BMES^XPDUTL("Error mapping Orderable Item: "_OI_" to new file structure.")
QUIT
+9 SET FDA(801.015,IENS,.01)="OI."_OI
End DoDot:1
+10 SET IENS=""
SET CNT=0
FOR
SET IENS=$ORDER(FDA(801.015,IENS))
if IENS=""
QUIT
Begin DoDot:1
+11 SET CNT=CNT+1
+12 IF $GET(FDA(801.015,IENS,.01))'["OI"
QUIT
+13 SET IEN=+$PIECE(IENS,",")
+14 SET IENROOT(IEN)=CNT
End DoDot:1
+15 QUIT
+16 ;
+17 ;=============
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 ;
