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

PXRMP45I.m

Go to the documentation of this file.
PXRMP45I ;ISP/RFR - PATCH 45 INSTALLATION ;Jan 03, 2020@14:35
 ;;2.0;CLINICAL REMINDERS;**45**;Feb 04, 2005;Build 566
 I '$$PATCH^XPDUTL("PXRM*2.0*45") D
 .N ENTRY,ENTRIES
 .S ENTRIES("UPDATE_2_0_54 VA-TERATOGENIC MEDICATIONS ORDER CHECKS(UPDATE #4)")="06/25/2018@08:36:44"
 .S ENTRIES("UPDATE_2_0_16 VA-WH MAMMOGRAM SCREENING")="09/15/2017@05:59:09"
 .S ENTRY="" F  S ENTRY=$O(ENTRIES(ENTRY)) Q:ENTRY=""  I +$$EXCHINCK(ENTRY,ENTRIES(ENTRY))<1 D
 ..W !,ENTRY,!,"is not installed.",!
 ..S XPDABORT=2
 Q
 ;
DLGTTL ;dialog and title text pairs for link code
 ;;VA-WH SMART PT NOTIFICATION^SMART PATIENT NOTIFICATION
 ;;VA-WH SMART BREAST IMAGING FOLLOW-UP^SMART BREAST IMAGING FOLLOW-UP^BREAST IMAGING FOLLOW-UP
 ;;VA-WH SMART BR OUTSIDE REPORT^SMART OUTSIDE BREAST IMAGE RESULTS
 ;;VA-WH UPDATE PREGNANCY STATUS^PREGNANCY STATUS UPDATE REVIEW^PREGNANCY/INTENTIONS/CONTRACEPTION
 ;;VA-WH UPDATE LACTATION STATUS^LACTATION STATUS UPDATE REVIEW^UPDATE LACTATION STATUS
 ;;EOF
 ;
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
 ;
FMERROR(MESSAGES) ;RETURN FILEMAN ERROR MESSAGE(S) AS STRING
 N ITEM,ERROR,ERRNUM,ERRORS
 S ERROR="",ERRNUM=0
 F  S ERRNUM=$O(MESSAGES("DIERR",ERRNUM)) Q:'+ERRNUM  D
 .Q:$D(ERRORS($G(MESSAGES("DIERR",ERRNUM))))
 .S ITEM=0 F  S ITEM=$O(MESSAGES("DIERR",ERRNUM,"TEXT",ITEM)) Q:ITEM=""  D
 ..S ERROR=$S(ERROR'="":ERROR_" ",1:"")_MESSAGES("DIERR",ERRNUM,"TEXT",ITEM)
 .S ERRORS=$G(MESSAGES("DIERR",ERRNUM))
 .I ERRORS'="" S ERRORS(ERRORS)=""
 Q ERROR
 ;
 D BMES^XPDUTL("  Creating entries in shared templates...")
 N GLOBAL,REMDLG,TEMPNAME,TITLE,TEXTPAIR,TEXTCNT,TMPONLY
 S GLOBAL="TIU(8925.1,",TMPONLY=0
 F TEXTCNT=1:1 S TEXTPAIR=$P($T(DLGTTL+TEXTCNT),";",3) Q:TEXTPAIR="EOF"  D
 . S REMDLG=$P(TEXTPAIR,U),TITLE=$P(TEXTPAIR,U,2),TEMPNAME=$P(TEXTPAIR,U,3)
 . D LINK2TIU^PXRMDUTL(REMDLG,TITLE,TEMPNAME,TMPONLY,GLOBAL)
 D MES^XPDUTL("  DONE")
 Q
 ;
LINK2WH ;update WV PROCEDURE TYPE file
 D BMES^XPDUTL("  Updating WV PROCEDURE TYPE file entries...")
 N DA,DIE,DR,RTIEN,RTNAME,WHARRAY,WHIEN,WHNAME
 S DIE="^WV(790.2,",DR="3////^S X=RTIEN"
 S WHARRAY("BREAST MRI")="VA-WH MRI OF THE BREASTS CODES"
 S WHARRAY("BREAST ULTRASOUND")="VA-WH ULTRASOUND OF THE BREAST CODES"
 S WHARRAY("MAMMOGRAM DX BILAT")="VA-WH MAMMOGRAM BILAT DIAGNOSTIC CODES"
 S WHARRAY("MAMMOGRAM DX UNILAT")="VA-WH MAMMOGRAM UNILAT DIAGNOSTIC CODES"
 S WHARRAY("MAMMOGRAM SCREENING")="VA-WH MAMMOGRAM SCREENING CODES"
 S WHNAME="" F  S WHNAME=$O(WHARRAY(WHNAME)) Q:WHNAME=""  D
 .S RTNAME=WHARRAY(WHNAME)
 .D BMES^XPDUTL("  Updating WV Procedure Type "_WHNAME)
 .S WHIEN=$O(^WV(790.2,"B",WHNAME,"")) I WHIEN'>0  D BMES^XPDUTL("Could not find entry: "_WHNAME) Q
 .S RTIEN=$O(^PXRMD(811.5,"B",RTNAME,"")) I RTIEN'>0 D BMES^XPDUTL("Could not find reminder term: "_RTNAME) Q
 .S DA=WHIEN
 .D ^DIE
 D MES^XPDUTL("  DONE")
 Q
 ;
POST ;Post-init
 N DIK,LUVALUE,LIST,DIK,DA,CNT,FDA,SUB,IEN,IENS,NAME,OI
 D POSTOC
 D BMES^XPDUTL("  Reindexing the DISPLAY NAME field in file #801.1...")
 S DIK="^PXD(801.1,",DIK(1)=1 D ENALL2^DIK,ENALL^DIK
 D MES^XPDUTL("  DONE")
 D POST^PXRMP45D,REBUILD^PXRMP45D
 ;Install Exchange File entries.
 D SMEXINS^PXRMEXSI("EXARRAY","PXRMP45E")
 D SETPARM,RENAME("POST-INSTALL"),RENAME("BUILD265")
 ;Enable options and protocols
 D OPTIONS^PXRMUTIL("ENABLE","Install of PXRM*2.0*45")
 D PROTCOLS^PXRMUTIL("ENABLE","Install of PXRM*2.0*45")
 D SETPVER^PXRMUTIL("2.0P45"),SENDIM
 K PXRMINST,PXRMINCF
 Q
 ;
POSTOC ;
 N CNT,DIK,DONE,FDA,IEN,IENS,NAME,OI,SUB
 S SUB="PXRM ORDER CHECK CONVERSION"
 I '$D(^XTMP(SUB)) Q
 D BMES^XPDUTL("  Updating Reminder Order Check Groups...")
 S IEN=0 F  S IEN=$O(^PXD(801,IEN)) Q:+IEN'>0  D
 .K FDA S CNT=0 I '$D(^XTMP(SUB,IEN)) Q
 .S NAME=$P($G(^PXD(801,IEN,0)),U)
 .D MES^XPDUTL("  Updating group: "_NAME)
 .S OI=0 F  S OI=$O(^XTMP(SUB,IEN,OI)) Q:OI'>0  D
 ..S CNT=CNT+1,IENS="+"_CNT_","_IEN_","
 ..S FDA(801.015,IENS,.01)=$S(OI[";":OI,1:OI_";ORD(101.43,")
 .I $D(FDA) D UPDATE(.FDA,SUB,NAME,IEN)
 D MES^XPDUTL("  DONE")
 D BMES^XPDUTL("  Reindexing file #801...")
 S DIK="^PXD(801,"
 D IXALL2^DIK,IXALL^DIK
 S IEN=0,DONE=1 F  S IEN=$O(^XTMP(SUB,IEN)) Q:+IEN'>0!(DONE=0)  D
 .I +$G(^XTMP(SUB,IEN,"DONE"))=0 S DONE=0
 I DONE=1 K ^XTMP(SUB)
 D MES^XPDUTL("  DONE")
 Q
 ;
PRE ;Pre-init
 ;Disable options and protocols
 D OPTIONS^PXRMUTIL("DISABLE","Install of PXRM*2.0*45")
 D PROTCOLS^PXRMUTIL("DISABLE","Install of PXRM*2.0*45")
 D DELEXE^PXRMEXSI("EXARRAY","PXRMP45E")
 S (PXRMINST,PXRMINCF)=1
 D PREOC,PRE^PXRMP45D,RENAME("PRE-INSTALL")
 ;Delete exisitng data dictionaries
 N DIU,DA,DIK,IEN,OI,SUB
 S DIU(0)=""
 F DIU=801,801.41,801.46,801.47,801.48,811.8,811.9 D MES^XPDUTL("  Deleting data dictionary for file #"_DIU_"..."),EN^DIU2,MES^XPDUTL("    DONE")
 Q
 ;
PREOC ;
 N FOUND,IEN,OI,SUB,MSG
 S SUB="PXRM ORDER CHECK CONVERSION"
 K ^XTMP(SUB)
 S ^XTMP(SUB,0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"PXRM Patch 45 Order Check Conversion",FOUND=0
 S MSG(1)="  Copying existing orderable item data from REMINDER ORDER CHECK ITEMS GROUP",MSG(2)="  file..."
 D MES^XPDUTL(.MSG)
 S IEN=0 F  S IEN=$O(^PXD(801,IEN)) Q:IEN'>0  D
 .I '$D(^PXD(801,IEN,2,"B")) Q
 .S OI=0 F  S OI=$O(^PXD(801,IEN,2,"B",OI)) Q:OI'>0  S ^XTMP(SUB,IEN,OI)="",FOUND=1
 I FOUND=0 D MES^XPDUTL("    None found") K ^XTMP(SUB) Q
 D MES^XPDUTL("    DONE")
 S MSG(1)="  Deleting existing orderable item data from REMINDER ORDER CHECK ITEMS GROUP"
 D MES^XPDUTL(.MSG)
 S IEN=0 F  S IEN=$O(^XTMP(SUB,IEN)) Q:IEN'>0  K ^PXD(801,IEN,2)
 D MES^XPDUTL("    DONE")
 D MES^XPDUTL("  Removing old cross-references...")
 K ^PXD(801,"AOIR"),^PXD(801,"O")
 D MES^XPDUTL("    DONE")
 Q
 ;
RENAME(CALLER) ;Rename components
 N ITEMS,GLOBAL,ITEM,TEST,TYPES,MSG
 S TYPES("^PXD(811.9,")="reminder definition"
 S TYPES("^PXD(801.1,")="order check rule"
 S TYPES("^PXRMD(811.5,")="term"
 S TYPES("^PXD(801,")="order check group"
 S TYPES("^PXD(811.2,")="taxonomy"
 S TYPES("^PXRM(810.4,")="list rule"
 I $G(CALLER)="PRE-INSTALL" D
 .S ITEMS("^PXD(811.9,","VA-TERATOGENIC MEDICATIONS ORDER CHECK")="VA-WH HIRISK ORDER CHECK - PREGNANT"
 .S ITEMS("^PXD(801.1,","VA-TERATOGENIC MEDICATIONS ORDER CHECK (CAT D) RULE")="VA-WH HIRISK MEDS (MODERATE/HIGH RISK) PREG RULE"
 .S ITEMS("^PXD(801.1,","VA-TERATOGENIC MEDICATIONS ORDER CHECK (CAT X) RULE")="VA-WH HIRISK MEDS (EXTREME RISK) PREG RULE"
 .S ITEMS("^PXD(801,","VA-TERATOGENIC MEDICATIONS (CAT D OR C) GROUP")="VA-WH HIRISK MEDICATIONS (MOD/HIGH RISK DURING PREGNANCY) GROUP"
 .S ITEMS("^PXD(801,","VA-TERATOGENIC MEDICATIONS (CAT X) GROUP")="VA-WH HIRISK MEDICATIONS (EXTREME RISK) GROUP"
 .S ITEMS("^PXD(811.2,","VA-TERATOGENIC MEDICATIONS ORDER CHECK EXCL (TAXONOMIES)")="VA-WH TERATOGENIC MEDICATIONS EXCLUSIONS TAXONOMY"
 I $G(CALLER)="POST-INSTALL" D
 .S ITEMS("^PXRMD(811.5,","VA-TERATOGENIC MEDICATIONS ORDER CHECK EXCLUSIONS (TERM)")="@"
 .S ITEMS("^PXRMD(811.5,","VA-WH IUD INSERTION (TERM)")="@"
 .S ITEMS("^PXRMD(811.5,","VA-WH IUD REMOVAL (TERM)")="@"
 I $G(CALLER)="BUILD265" D
 .S ITEMS("^PXD(811.9,","VA-WH BLOCK PREGNANCY AND LACTATION DATA ENTRY")="VA-WH PREGNANCY AND LACTATION DATA ENTRY ALLOWED"
 S GLOBAL="" F  S GLOBAL=$O(ITEMS(GLOBAL)) Q:GLOBAL=""  S ITEM="" F  S ITEM=$O(ITEMS(GLOBAL,ITEM)) Q:ITEM=""  D
 .S TEST=GLOBAL_"""B"","""_ITEM_""",0)"
 .S IEN=+$O(@TEST)
 .Q:'IEN
 .K MSG
 .S MSG(1)="  "_$S(ITEMS(GLOBAL,ITEM)'="@":"Renaming",1:"Deleting")_" the "_ITEM,MSG(2)="  "_TYPES(GLOBAL)_"..."
 .D MES^XPDUTL(.MSG)
 .I ITEMS(GLOBAL,ITEM)="@" D DELTLFE^PXRMUTIL($P($P(GLOBAL,"(",2),","),ITEM)
 .I ITEMS(GLOBAL,ITEM)'="@" D RENAME^PXRMUTIL($P($P(GLOBAL,"(",2),","),ITEM,ITEMS(GLOBAL,ITEM))
 .D MES^XPDUTL("    DONE")
 Q
 ;
SENDIM ;Send install message.
 N FROM,NODE,PARAM,SYSTEM,SUBJECT,TO,VALUE
 S NODE="PXRM*2.0*45"
 K ^TMP(NODE,$J)
 ;DBIA #1131 for ^XMB("NETNAME")
 S FROM=NODE_" Install@"_^XMB("NETNAME")
 ;DBIA #2541
 S SYSTEM=$$KSP^XUPARAM("WHERE")
 I $$PROD^XUPROD(1) S TO("G.CLINICAL REMINDERS SUPPORT@DOMAIN.EXT")=""
 E  D
 . N MGIEN,MGROUP
 . S MGIEN=$G(^PXRM(800,1,"MGFE"))
 . S MGROUP=$S(MGIEN'="":"G."_$$GET1^DIQ(3.8,MGIEN,.01),1:DUZ)
 . S TO(MGROUP)=""
 S SUBJECT="Install of "_NODE
 S ^TMP(NODE,$J,1,0)=NODE_" was installed."
 S ^TMP(NODE,$J,2,0)="System is "_SYSTEM
 D SEND^PXRMMSG(NODE,SUBJECT,.TO,FROM)
 Q
 ;
SETPARM() ;
 N PROD
 S PROD=$$PROD^XUPROD(1)
 D PUT^XPAR("SYS","PXRM DIALOG EVAL DEFINITION",,0)
 Q
 ;
UPDATE(FDA,SUB,NAME,IEN) ;
 N MSG,NAME,OI,OINAME
 D UPDATE^DIE("","FDA","","MSG")
 I '$D(MSG) S ^XTMP(SUB,IEN,"DONE")=1 Q
 ;If error display error and original structures
 I $D(MSG) D AWRITE^PXRMUTIL("MSG") D
 .S ^XTMP(SUB,IEN,"DONE")=0
 .D MES^XPDUTL("Manual correction is needed.")
 .D MES^XPDUTL("Someone needs to manually move the orderable items listed below to the ITEMS LIST section.")
 .D MES^XPDUTL("Reminder Group Name: "_$P($G(^PXD(801,IEN,0)),U))
 .S OI=0 F  S OI=$O(^XTMP(SUB,IEN,OI)) Q:OI'>0  D
 ..S OINAME=$P($G(^ORD(101.43,OI,0)),U) I OINAME="" Q
 ..D MES^XPDUTL("  "_OINAME)
 Q
 ;