- 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 Feb 18, 2025@23:11:43 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 ;