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

PXRMEXIC.m

Go to the documentation of this file. 
PXRMEXIC ;SLC/PKR,PJH - Routines to install repository entry components. ;Mar 12, 2025@10:34:59

 ;;2.0;CLINICAL REMINDERS;**6,12,17,16,18,22,24,26,47,45,87**;Feb 04, 2005;Build 35

 ;

 ; Reference to KILLUPDATING^ORIUTL in ICR# 7465

 ;

 Q

 ;=================================================

FILE(PXRMRIEN,SITEIEN,IND120,JND120,ACTION,ATTR,NAMECHG) ;Read and process a

 ;file entry in repository entry PXRMRIEN. IND120 and JND120 are the

 ;indexes for the component list. ACTION is one of the possible actions.

 I ACTION="S" Q

 N CLASS,CLASSFIELDNUM,DATA,DUZ0S,EDULIST,FDA,FDAEND,FDASTART,FIELD,FILENUM

 N IEN,IENS,IENREND,IENROOT,IENRSTR,IENUSED,IND,INDICES

 N LINE,MSG,NAME,NEW01,PT01,PXNAT,PXRMEDOK,PXRMEXCH

 N SRCIEN,START,TEMP,TEXT,TFDA,TIENROOT,TIUFPRIV,TNAME,TOPFNUM

 N UPCNAME,UPCPT01,VERSN,WPLCNT,WPTMP,XUMF

 ;I $G(PXRMIGDS) S DUZ0S=DUZ(0),DUZ(0)="^",XUMF=1

 ;Set PXRMEDOK so files pointing to sponsors can be installed.

 ;Set PXRMEXCH so national entries can be installed and prevent

 ;execution of the input transform for custom logic fields.

 ;Set PXNAT to allow installation of national PCE data types.

 S (PXNAT,PXRMEDOK,PXRMEXCH)=1

 S TEMP=^PXD(811.8,PXRMRIEN,120,IND120,1,JND120,0)

 S FDASTART=+$P(TEMP,U,2)

 S FDAEND=+$P(TEMP,U,3)

 S IENRSTR=+$P(TEMP,U,4)

 S IENREND=+$P(TEMP,U,5)

 F IND=FDASTART:1:FDAEND D

 . S LINE=^PXD(811.8,PXRMRIEN,100,IND,0)

 . S INDICES=$P(LINE,"~",1)

 . S DATA=$P(LINE,"~",2)

 . S FILENUM=$P(INDICES,";",1)

 . S IENS=$P(INDICES,";",2)

 . I IND=FDASTART S SRCIEN=+IENS

 . S FIELD=$P(INDICES,";",3)

 . I LINE["WP-start" D

 .. S DATA="WPTMP("_IND_","_+FIELD_")"

 .. S WPLCNT=$P(LINE,"~",3)

 .. D WORDPROC(PXRMRIEN,.WPTMP,IND,+FIELD,.IND,WPLCNT)

 . I (IND=FDASTART)&((FIELD=.01)!(FIELD=.001)) D

 ..;Save the top level file number.

 .. S TOPFNUM=FILENUM

 ..;If the action is copy put it in the first open spot.

 .. I ACTION="C" S IENROOT(SRCIEN)=$$LOIEN^PXRMEXU5(TOPFNUM,0)

 ..;

 ..;If the entry does not exist and the action is not copy set the

 ..;action to install.

 .. I SITEIEN=0 S ACTION="I"

 ..;

 ..;If the action is install try to install at the source IEN. If

 ..;an entry already exists at the source IEN put it in the first

 ..;open spot.

 .. I ACTION="I" D

 ... S IENUSED=+$$FIND1^DIC(FILENUM,"","QU","`"_SRCIEN)

 ... S IENROOT(SRCIEN)=$S(IENUSED=0:SRCIEN,1:$$LOIEN^PXRMEXU5(FILENUM))

 ..;

 ..;If the action is merge, overwrite,or update install at the site's

 ..;IEN.

 .. I (ACTION="M")!(ACTION="O")!(ACTION="U") S IENROOT(SRCIEN)=SITEIEN

 .;

 .;This line is use to convert pre-patch 12 disable text to the new

 .;value of 1 for disable

 . I FILENUM=801.41,FIELD=3,DATA'="",$L(DATA)>2 D

 ..I DATA="DISABLE AND DO NOT SEND MESSAGE" Q

 ..S DATA="DISABLE AND SEND MESSAGE"

 .;

 . S FDA(FILENUM,IENS,FIELD)=DATA

 ;

 S IENS=$O(FDA(TOPFNUM,""))

 ;

 ;Initialize the edit history.

 D INIEH(TOPFNUM,IENS,.FDA,.WPTMP)

 ;

 ;S CLASSFIELDNUM=$$FLDNUM^DILFD(TOPFNUM,"CLASS")

 ;I CLASSFIELDNUM>0 D

 ;.;If there is no Class, default it to local.

 ;. S CLASS=$G(FDA(TOPFNUM,IENS,CLASSFIELDNUM))

 ;. I CLASS="" S FDA(TOPFNUM,IENS,100)="LOCAL"

 ;

 ;Initialize the Change Log/Edit History.

 ;S PT01=FDA(TOPFNUM,IENS,.01)

 ;S UPCPT01=$$UP^XLFSTR(PT01)

 ;D INIEH(PXRMRIEN,TOPFNUM,PT01,UPCPT01,.FDA,.NAMECHG,.WPTMP)

 ;

 ;If there is a Sponsor does it need to be replaced?

 ;S SPONFIELDNUM=$$FLDNUM^DILFD(TOPFNUM,"SPONSOR")

 ;I SPONFIELDNUM>0 D

 ;. S SPONSOR=$G(FDA(TOPFNUM,IENS,SPONFIELDNUM))

 ;. I (SPONSOR'=""),$D(^PXRMD(811.6,"REP",SPONSOR)) D

 ;.. S REPSPONIEN=$O(^PXRMD(811.6,"REP",SPONSOR,""))

 ;.. S FDA(TOPFNUM,IENS,SPONFIELDNUM)="`"_REPSPONIEN

 ;

 ;Some older PRD files may contain mixed-case. Make sure

 ;the appropriate fields in the FDA are uppercase.

 ;D UPPERCASE^PXRMEXUPC(TOPFNUM,.FDA)

 ;

 ;Build the IENROOT

 F IND=IENRSTR:1:IENREND D

 . I IND=0 Q

 . S TEMP=^PXD(811.8,PXRMRIEN,100,IND,0)

 . S IENROOT($P(TEMP,U,1))=$P(TEMP,U,2)

 ;Check for name changes, i.e., the copy action.

 D NAMECHG(.FDA,.NAMECHG,TOPFNUM)

 ;

 ;Special handling for file 142.

 I TOPFNUM=142 D  Q:'$D(FDA)

 . D SFMVPI^PXRMEXIU(.FDA,.NAMECHG,142.14)

 ;

 ;Special handling for file 801

 I TOPFNUM=801 D  Q:PXRMDONE

 . D SFMVPI^PXRMEXIU(.FDA,.NAMECHG,801.015)

 . D ROC^PXRMEXU5(.FDA,.IENROOT)

 ;

 ;Special handling for file 801.1

 I TOPFNUM=801.1 D  Q:PXRMDONE

 . D ROCR^PXRMEXU5(.FDA)

 ;

 I TOPFNUM=801.48 D DLINKSAV^PXRMEXU5(.FDA) Q:PXRMDONE

 ;Special handling for file 801.41

 I TOPFNUM=801.41 D  Q:PXRMDONE

 . ;Merge only applies when the silent installer is used.

 . I ACTION="M" D MOU^PXRMEXU5(801.41,SITEIEN,"18*",.FDA,.IENROOT,ACTION,.WPTMP)

 . D DLG^PXRMEXU4(.FDA,.NAMECHG)

 ;

 ;Special handling for file 810.9

 I TOPFNUM=810.9 D LOC^PXRMEXU0(.FDA)

 ;

 ;Special handling for file 811.2

 I TOPFNUM=811.2 D TAX^PXRMEXU0(.FDA,"CFR")

 ;

 I TOPFNUM=801.46 D DIALOGGF^PXRMEXU5(.FDA,.IENROOT)

 ;

 ;If the file number is 811.4 the user must have programmer

 ;access to install it.

 I (TOPFNUM=811.4)&(DUZ(0)'="@") D  Q

 . W !,"Only programmers can install Reminder Computed Findings."

 ;

 ;Special handling for file 811.5.

 I TOPFNUM=811.5 D  Q:'$D(FDA)

 .;set default usage if not defined

 .I $G(FDA(811.5,IENS,103))="" S FDA(811.5,IENS,103)="*"

 .;If the site has any findings already mapped merge them in.

 . I (ACTION="M")!(ACTION="U") D MOU^PXRMEXU5(811.5,SITEIEN,"20*",.FDA,.IENROOT,ACTION,.WPTMP)

 . D SFMVPI^PXRMEXIU(.FDA,.NAMECHG,811.52)

 ;

 ;Special handling for file 811.9.

 I TOPFNUM=811.9 D

 .;Don't execute the input transform for custom logic fields.

 . S PXRMEXCH=1

 . D DEF^PXRMEXIU(.FDA,.NAMECHG)

 ;

 ;Special handling for file 8925.1

 I TOPFNUM=8925.1 D

 . S TIUFPRIV=1

 . D TIUOBJ^PXRMEXIU(.FDA)

 ;

 ;Special handling for file 9999999.09: Education Topics.

 I TOPFNUM=9999999.09 D EDU^PXRMEXIU(.FDA,.EDULIST)

 ;

 ;Special handling for file 9999999.15: Exams.

 I TOPFNUM=9999999.15 D EXAM^PXRMEXIU(.FDA)

 ;

 ;Special handling for file 9999999.64: Health Factors.

 I TOPFNUM=9999999.64 D HF^PXRMEXIU(.FDA)

 ;

 I TOPFNUM=101.71 D EN^PXRMEXUINFOPNL(.FDA) I PXRMDONE=1 Q

 ;

 ;If FDA is not defined at this point the user has opted to abort

 ;the install.

 I '$D(FDA) Q

 ;

 ;If the action is merge, overwrite, or update do a test install

 ;before deleting the original entry.

 I (ACTION="M")!(ACTION="O")!(ACTION="U") D

 .I TOPFNUM=101.71 Q

 .;Make the .01 unique for the test install.

 . S IENS=$O(FDA(TOPFNUM,""))

 .;Get the length of the .01 field

 . D FIELD^DID(TOPFNUM,.01,"","FIELD LENGTH","ATTR")

 . S TNAME="tmp"_$E(FDA(TOPFNUM,IENS,.01),1,ATTR("FIELD LENGTH")-3)

 .;Make sure the test entry does not already exist.

 . D DELALL^PXRMEXFI(TOPFNUM,TNAME)

 . M TFDA=FDA

 . S TFDA(TOPFNUM,IENS,.01)=TNAME

 . K TIENROOT M TIENROOT=IENROOT

 . S TIENROOT(SRCIEN)=$$LOIEN^PXRMEXU5(TOPFNUM)

 . D UPDATE^DIE("E","TFDA","TIENROOT","MSG")

 . I $D(MSG) D  Q

 .. K TEXT

 .. S TEXT(1)="FILE^PXRMEXIC, "_ATTR("FILE NAME")_" entry "_$G(ATTR("PT01"))_" did not get installed!"

 .. S TEXT(2)="Examine the following error message for the reason."

 .. S TEXT(3)=""

 .. S TEXT(4)="The test update failed, UPDATE^DIE returned the following error message:"

 .. D MES^XPDUTL(.TEXT)

 .. D AWRITE^PXRMUTIL("MSG")

 .. H 2

 .;Delete the test entry.

 . D DELALL^PXRMEXFI(TOPFNUM,TNAME)

 .;If the original update worked put the entry at its original ien.

 .;Delete the existing entry.

 . D DELETE^PXRMEXFI(TOPFNUM,SITEIEN)

 ;

 D UPDATE^DIE($S(TOPFNUM=101.71:"ESU",1:"ES"),"FDA","IENROOT","MSG")

 I TOPFNUM=101.71 D KILLUPDATING^ORIUTL

 ;

 I '$D(MSG),ATTR("FILE NUMBER")=9999999.64 D

 .;Build a list of health factor categories that need the [C] appended

 . N IENS

 . S IENS=$O(FDA(9999999.64,""))

 . I FDA(9999999.64,IENS,.1)'="CATEGORY" Q

 . N L4C,LEN,NAME

 . S NAME=ATTR("NAME")

 . S LEN=$L(NAME),L4C=$E(NAME,(LEN-3),LEN)

 . I L4C'=" [C]" D

 .. S UPCNAME=$$UP^XLFSTR(NAME)

 .. S ^TMP("PXRMHFCAT",$J,UPCNAME)=""

 I $D(MSG) D

 . K TEXT

 . S TEXT(1)="FILE^PXRMEXIC, "_ATTR("FILE NAME")_" entry "_$G(ATTR("PT01"))_" did not get installed!"

 . S TEXT(2)="Examine the following error message for the reason."

 . S TEXT(3)=""

 . S TEXT(4)="The update failed, UPDATE^DIE returned the following error message:"

 . D MES^XPDUTL(.TEXT)

 . D AWRITE^PXRMUTIL("MSG") W ! D AWRITE^PXRMUTIL("FDA")

 . W !

 . H 2

 ;

 I TOPFNUM=811.2 D

 .;Finish conversion from pointer based structure to Lexicon based.

 . N IEN,PDS

 . S IEN=+$O(^PXD(811.2,"B",ATTR("NAME"),""))

 . I IEN=0 Q

 . D EXCH^PXRMTXCR(IEN,"CFR")

 . S PDS=$P(^PXD(811.2,IEN,0),U,4)

 . I PDS="" D SPDS^PXRMPDS(IEN,PDS)

 .;If there are codes marked Use In Dialog build the 30 node.

 . D BLD30N^PXRMTAXD(IEN)

 ;

 S VERSN=$$GETTAGV^PXRMEXU3(^PXD(811.8,PXRMRIEN,100,3,0),"<PACKAGE_VERSION>")

 I TOPFNUM=811.9,VERSN=1.5 D

 . N IEN,PXRMEXCH,X

 . S IEN=+$O(^PXD(811.9,"B",ATTR("PT01"),""))

 . I IEN=0 Q

 .;For reminder definitions build the found/not found text counts.

 . D SFNFTC^PXRMEXU0(IEN)

 .;Build the internal logic and finding strings.

 . S X=$G(^PXD(811.9,IEN,30))

 . I X'="" D CPPCLS^PXRMLOGX(IEN,X)

 . S X=$G(^PXD(811.9,IEN,34))

 . I X'="" D CPRESLS^PXRMLOGX(IEN,X)

 . D BLDALL^PXRMLOGX(IEN,"","")

 ;If there are national education topics rename them so they start

 ;with VA-

 I $D(EDULIST),$G(PXRMNAT) D

 .;Get the length of the .01 field

 . D FIELD^DID(TOPFNUM,.01,"","FIELD LENGTH","ATTR")

 . S NAME=""

 . F  S NAME=$O(EDULIST(NAME)) Q:NAME=""  D

 .. I $E(NAME,1,3)="VA-" Q

 .. S TNAME="VA-"_$E(ATTR("FIELD LENGTH")-3)

 .. D RENAME^PXRMUTIL(TOPFNUM,NAME,TNAME)

 ;I $G(PXRMIGDS) S DUZ(0)=DUZ0S

 Q

 ;

 ;=================================================

INIEH(FILENUM,IENS,FDA,WPTMP) ;If the file is a clinical reminder file and

 ;it has an edit history initialize the history.

 I (FILENUM<800)!(FILENUM>811.9) Q

 N IENS,SFN,TARGET,WP

 D FIELD^DID(FILENUM,"CHANGE LOG","","SPECIFIER","TARGET")

 S SFN=+$G(TARGET("SPECIFIER"))

 I SFN=0 D FIELD^DID(FILENUM,"EDIT HISTORY","","SPECIFIER","TARGET")

 S SFN=+$G(TARGET("SPECIFIER"))

 I SFN=0 Q

 S IENS=$O(FDA(SFN,""))

 I IENS="" Q

 S FDA(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")

 S FDA(SFN,IENS,1)="`"_DUZ

 ;The word-processing field is set when the packing is done.

 S WP=FDA(SFN,IENS,2)

 K @WP

 S @WP@(1)="Exchange Install"

 Q

 ;

 ;=================================================

NAMECHG(FDA,NAMECHG,FILENUM) ;If this component has been copied to a new

 ;name make the change.

 N CLASS,IENS,PT01

 S IENS=$O(FDA(FILENUM,""))

 S PT01=FDA(FILENUM,IENS,.01)

 I $D(NAMECHG(FILENUM,PT01)) D

 . S FDA(FILENUM,IENS,.01)=NAMECHG(FILENUM,PT01)

 . I (FILENUM<801.41)!(FILENUM>811.9) Q

 .;Once a component has been copied CLASS can no longer be national.

 . S CLASS=$G(FDA(FILENUM,IENS,100))

 . I (CLASS="")!(CLASS["N") S FDA(FILENUM,IENS,100)="LOCAL"

 .;The Sponsor is also removed.

 . K FDA(FILENUM,IENS,101)

 Q

 ;

 ;=================================================

RTNLD(PXRMRIEN,START,END,ATTR,RTN) ;Load a routine from the repository into

 ;the array RTN.

 N IND,LINE,LN,ROUTINE

 S LINE=^PXD(811.8,PXRMRIEN,100,START,0)

 S ROUTINE=$P(LINE,";",1)

 S ROUTINE=$TR(ROUTINE," ","")

 S ATTR("FILE NUMBER")=0

 S ATTR("NAME")=$P(LINE,";",1)

 S ATTR("NAME")=$TR(ATTR("NAME")," ","")

 S ATTR("MIN FIELD LENGTH")=3

 S ATTR("FIELD LENGTH")=8

 S LN=0

 F IND=START:1:END D

 . S LN=LN+1

 . S LINE=^PXD(811.8,PXRMRIEN,100,IND,0)

 . S RTN(LN,0)=LINE

 Q

 ;

 ;=================================================

RTNSAVE(RTN,NAME) ;Save the routine loaded in RTN to the name

 ;found in NAMECHG.

 N DIE,XCN

 ;%ZOSF("SAVE") requires a global.

 K ^TMP($J,"PXRMRTN")

 S DIE="^TMP($J,""PXRMRTN"","

 M ^TMP($J,"PXRMRTN")=RTN

 S XCN=0

 S X=NAME

 X ^%ZOSF("SAVE")

 K ^TMP($J,"PXRMRTN")

 Q

 ;

 ;=================================================

WORDPROC(PXRMRIEN,WPTMP,I1,I2,IND,WPLCNT) ;Load WPTMP with the word

 ;processing field.

 N I3

 F I3=1:1:WPLCNT D

 . S IND=IND+1

 . S WPTMP(I1,I2,I3)=$G(^PXD(811.8,PXRMRIEN,100,IND,0))

 Q

 ;