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

PXRMP4I.m

Go to the documentation of this file. 
  1. PXRMP4I ; SLC/PKR - PXRM*2.0*4 init routine. ;07/24/2006
  1.  ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  1.  Q
  1.  ;
  1.  ;==========================================
  1. CFTINC(IEN) ;Return true if the computed finding should be included
  1.  ;in the build.
  1.  N NAME
  1.  S NAME=$P(^PXRMD(811.4,IEN,0),U,1)
  1.  I NAME="VA-APPOINTMENTS FOR A PATIENT" Q 1
  1.  I NAME="VA-DATE OF BIRTH" Q 1
  1.  I NAME="VA-DATE OF DEATH" Q 1
  1.  I NAME="VA-HOSPITAL DISCHARGE DATE" Q 1
  1.  I NAME="VA-PATIENT TYPE" Q 1
  1.  I NAME="VA-PATIENTS WITH APPOINTMENTS" Q 1
  1.  I NAME="VA-PROGRESS NOTE" Q 1
  1.  I NAME="VA-PTF HOSPITAL DISCHARGE DATE" Q 1
  1.  I NAME="VA-REMINDER DEFINITION" Q 1
  1.  I NAME="VA-TREATING FACILITY LIST" Q 1
  1.  Q 0
  1.  ;
  1.  ;==========================================
  1. DELDD ;Delete the old data dictionaries.
  1.  N DIU,TEXT
  1.  D EN^DDIOL("Removing old data dictionaries.")
  1.  S DIU(0)=""
  1.  F DIU=800,801.41,801.5,801.55,802.4,810.1,810.2,810.3,810.4,810.5,810.7,810.8,810.9,811.5,811.9 D
  1.  . S TEXT=" Deleting data dictionary for file # "_DIU
  1.  . D EN^DDIOL(TEXT)
  1.  . D EN^DIU2
  1.  Q
  1.  ;
  1.  ;==========================================
  1. DELEI ;If the Exchange File entry already exists delete it.
  1.  N ARRAY,IC,IND,LIST,LUVALUE,NUM
  1.  D EXARRAY^PXRMP4IW(1,.ARRAY)
  1.  S IC=0
  1.  F  S IC=$O(ARRAY(IC)) Q:'IC  D
  1.  . S LUVALUE(1)=ARRAY(IC,1)
  1.  . D FIND^DIC(811.8,"","","U",.LUVALUE,"","","","","LIST")
  1.  . I '$D(LIST) Q
  1.  . S NUM=$P(LIST("DILIST",0),U,1)
  1.  . I NUM'=0 D
  1.  .. F IND=1:1:NUM D
  1.  ... N DA,DIK
  1.  ... S DIK="^PXD(811.8,"
  1.  ... S DA=LIST("DILIST",2,IND)
  1.  ... D ^DIK
  1.  Q
  1.  ;
  1.  ;==========================================
  1. DELLT ;Delete list templates
  1.  N IEN,IND,LIST,TEMP0
  1.  D LTL^PXRMP4IW(.LIST)
  1.  S IND=0
  1.  F  S IND=$O(LIST(IND)) Q:IND=""  D
  1.  . S IEN=$O(^SD(409.61,"B",LIST(IND),"")) Q:IEN=""
  1.  . S TEMP0=$G(^SD(409.61,IEN,0))
  1.  . K ^SD(409.61,IEN)
  1.  . S ^SD(409.61,IEN,0)=TEMP0
  1.  Q
  1.  ;
  1.  ;==========================================
  1. EXFINC(Y) ;Return a 1 if the Exchange file entry is in the list to
  1.  ;include in the build. This is used in the build to determine which
  1.  ;entries to include.
  1.  N EXARRAY,FOUND,IEN,IC,LUVALUE
  1.  D EXARRAY^PXRMP4IW(1,.EXARRAY)
  1.  S FOUND=0
  1.  S IC=0
  1.  F  S IC=+$O(EXARRAY(IC)) Q:(IC=0)!(FOUND)  D
  1.  . M LUVALUE=EXARRAY(IC)
  1.  . S IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
  1.  . I IEN=Y S FOUND=1 Q
  1.  Q FOUND
  1.  ;
  1.  ;==========================================
  1. OVLCHECK ;Check existing reminder definitions for baseline age range
  1.  ;overlaps.
  1.  D BMES^XPDUTL("Checking reminder definitions for baseline age range overlap")
  1.  N DA,TEST
  1.  S DA=0
  1.  F  S DA=+$O(^PXD(811.9,DA)) Q:DA=0  D
  1.  . S TEST=$$OVLAP^PXRMAGE
  1.  . I TEST W !,"Reminder ",$P(^PXD(811.9,DA,0),U,1),"; IEN= ",DA,!
  1.  Q
  1.  ;
  1.  ;==========================================
  1. PRE ;
  1.  D SLLC
  1.  D DELDD
  1.  D DELEI
  1.  D DELLT
  1.  D RELTEMP^PXRMP4I1
  1.  D REOPTS^PXRMP4I1
  1.  D REPROTS^PXRMP4I1
  1.  N PXRMINST S PXRMINST=1
  1.  D RENAME^PXRMP4I1(811.4,"VA-DISCHARGE DATE","VA-LAST SERVICE SEPARATION DATE")
  1.  Q
  1.  ;
  1.  ;==========================================
  1. POST ;
  1.  D FORMAT^PXRMDISC
  1.  D OVLCHECK
  1.  D RLLC
  1.  ;D RTAXEXP
  1.  D RRSVC
  1.  D SPLT
  1.  D SAUTOP
  1.  D SLABENOD^PXRMP4I1
  1.  ;D SMEXINS
  1.  ;D POST^PXRMGECL
  1.  ;D MHVWEB^PXRMP4IW
  1.  ;D GECDIA^PXRMP4I1
  1.  ;D SNEXTIP^PXRMP4I1
  1.  Q
  1.  ;
  1.  ;==========================================
  1. RLLC ;Restore the Location List classes to the new location and delete
  1.  ;the old location.
  1.  N CLASS,IEN,TEMP
  1.  D BMES^XPDUTL("Restoring Location List Classes")
  1.  S IEN=0
  1.  F  S IEN=+$O(^XTMP("PXRMLLCS",IEN)) Q:IEN=0  D
  1.  . S CLASS=^XTMP("PXRMLLCS",IEN)
  1.  . S $P(^PXRMD(810.9,IEN,100),U,1)=CLASS
  1.  S IEN=0
  1.  F  S IEN=+$O(^PXRMD(810.9,IEN)) Q:IEN=0  D
  1.  . S CLASS=$P(^PXRMD(810.9,IEN,100),U,1)
  1.  . I CLASS="" D
  1.  .. S TEMP=$P(^PXRMD(810.9,IEN,0),U,2)
  1.  .. I TEMP'="" S $P(^PXRMD(810.9,IEN,100),U,1)=TEMP
  1.  .. S CLASS=TEMP
  1.  . I CLASS'="" D
  1.  .. S TEMP=^PXRMD(810.9,IEN,0)
  1.  .. S ^PXRMD(810.9,IEN,0)=$P(TEMP,U,1)
  1.  Q
  1.  ;
  1.  ;==========================================
  1. RRSVC ;Reformat reminder report template service categories.
  1.  N IEN,IND,SVCL
  1.  D BMES^XPDUTL("Reformatting reminder report service categories")
  1.  S IEN=0
  1.  F  S IEN=+$O(^PXRMPT(810.1,IEN)) Q:IEN=0  D
  1.  . S SVCL="",IND=0
  1.  . F  S IND=+$O(^PXRMPT(810.1,IEN,8,IND)) Q:IND=0  D
  1.  .. I SVCL="" S SVCL=^PXRMPT(810.1,IEN,8,IND,0)
  1.  .. E  S SVCL=SVCL_","_^PXRMPT(810.1,IEN,8,IND,0)
  1.  . I SVCL="" Q
  1.  . K ^PXRMPT(810.1,IEN,8)
  1.  . S ^PXRMPT(810.1,IEN,8)=SVCL
  1.  Q
  1.  ;
  1.  ;==========================================
  1. RSPC ;Restore the Sponsor classes to the new location.
  1.  N CLASS,IEN
  1.  D BMES^XPDUTL("Restoring Sponsor Classes")
  1.  S IEN=0
  1.  F  S IEN=+$O(^XTMP("PXRMSPCS",IEN)) Q:IEN=0  D
  1.  . S CLASS=^XTMP("PXRMSPCS",IEN)
  1.  . S $P(^PXRMD(811.6,IEN,100),U,1)=CLASS
  1.  Q
  1.  ;
  1.  ;==========================================
  1. RTAXEXP ;Rebuild all taxonomy expansions.
  1.  N ALOW,AHIGH,FILENUM,HIGH,LOW,IEN,IND,TEMP,TEXT,X,X1,X2
  1.  S (X1,X2)="TAX"
  1.  D BMES^XPDUTL("Rebuilding taxonomy expansions and setting adjacent values.")
  1.  S IEN=$O(^PXD(811.2,"B","VA-WH BILATERAL MASTECTOMY",""))
  1.  S TEXT=" Working on taxonomy "_IEN
  1.  D BMES^XPDUTL(TEXT)
  1.  D DELEXTL^PXRMBXTL(IEN)
  1.  D EXPAND^PXRMBXTL(IEN,"")
  1.  F FILENUM=80,80.1,81 D
  1.  . S IND=0
  1.  . F  S IND=+$O(^PXD(811.2,IEN,FILENUM,IND)) Q:IND=0  D
  1.  .. S TEMP=^PXD(811.2,IEN,FILENUM,IND,0)
  1.  .. S LOW=$P(TEMP,U,1),HIGH=$P(TEMP,U,2)
  1.  .. S ALOW=$S(FILENUM=80:$$PREV^ICDAPIU(LOW),FILENUM=80.1:$$PREV^ICDAPIU(LOW),FILENUM=81:$$PREV^ICPTAPIU(LOW))
  1.  .. S AHIGH=$S(FILENUM=80:$$NEXT^ICDAPIU(HIGH),FILENUM=80.1:$$NEXT^ICDAPIU(HIGH),FILENUM=81:$$NEXT^ICPTAPIU(HIGH))
  1.  .. S $P(^PXD(811.2,IEN,FILENUM,IND,0),U,3,4)=ALOW_U_AHIGH
  1.  D BMES^XPDUTL(" DONE")
  1.  Q
  1.  ;
  1.  ;==========================================
  1. SAUTOP ;Make sure the class field is "N" for national Extract Summary and
  1.  ;Reminder Patient List entries. For these entries set the field
  1.  ;AUTOMATICALLY PURGE to true. Set INCLUDE PCMM INSTITUTION to true
  1.  ;for all VA-*IHD QUERI and VA-*MH QUERI lists.
  1.  D BMES^XPDUTL("Setting AUTOMATICALLY PURGE for national Extract Summaries and Patient Lists")
  1.  N IEN,NAME
  1.  S IEN=0 F  S IEN=$O(^PXRMXT(810.3,IEN)) Q:IEN'>0  D
  1.  . S NAME=$P($G(^PXRMXT(810.3,IEN,0)),U)
  1.  . I NAME'["VA-",NAME'["LREPI" Q
  1.  . S $P(^PXRMXT(810.3,IEN,100),U)="N"
  1.  . S ^PXRMXT(810.3,IEN,50)=1
  1.  ;
  1.  S IEN=0 F  S IEN=$O(^PXRMXP(810.5,IEN)) Q:IEN'>0  D
  1.  . S NAME=$P($G(^PXRMXP(810.5,IEN,0)),U)
  1.  . I NAME["QUERI" S $P(^PXRMXP(810.5,IEN,0),U,10)=1
  1.  . I NAME'["VA-",NAME'["LREPI" Q
  1.  . S $P(^PXRMXP(810.5,IEN,100),U)="N"
  1.  . S ^PXRMXP(810.5,IEN,50)=1
  1.  Q
  1.  ;
  1.  ;==========================================
  1. SLLC ;Save the Location List classes.
  1.  N CDATE,CLASS,IEN,PDATE
  1.  D BMES^XPDUTL("Saving Location List Classes")
  1.  S CDATE=$$NOW^XLFDT
  1.  S PDATE=$$FMADD^XLFDT(CDATE,30)
  1.  S ^XTMP("PXRMLLCS",0)=PDATE_U_CDATE_U_"LOCATION LIST CLASSES"
  1.  S IEN=0
  1.  F  S IEN=+$O(^PXRMD(810.9,IEN)) Q:IEN=0  D
  1.  . S CLASS=$P(^PXRMD(810.9,IEN,0),U,2)
  1.  . I CLASS'="" S ^XTMP("PXRMLLCS",IEN)=CLASS
  1.  Q
  1.  ;
  1.  ;==========================================
  1. SMEXINS ;Silent mode install.
  1.  N EXARRAY,IC,IEN,LUVALUE,PXRMINST,TEXT
  1.  S PXRMINST=1
  1.  D EXARRAY^PXRMP4IW(1,.EXARRAY)
  1.  S IC=0
  1.  F  S IC=$O(EXARRAY(IC)) Q:'IC  D
  1.  .M LUVALUE=EXARRAY(IC)
  1.  .S IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
  1.  .I IEN'=0 D
  1.  .. N TEXT
  1.  .. I LUVALUE(1)["PARAMETER" S TEXT="Installing entry "_LUVALUE(1)
  1.  .. E  S TEXT="Installing reminder "_LUVALUE(1)
  1.  .. D BMES^XPDUTL(TEXT)
  1.  .. D INSTALL^PXRMEXSI(IEN,1)
  1.  Q
  1.  ;
  1.  ;==========================================
  1. SPLT ;Set the Patient List Type field. In the original version the list
  1.  ;was private only if the creator was stored. In the new version the
  1.  ;TYPE field will be used to mark a list as public or private and
  1.  ;the creator will be stored for all lists.
  1.  N CREATOR,IEN,TYPE
  1.  D BMES^XPDUTL("Setting Patient List TYPE field")
  1.  S IEN=0
  1.  F  S IEN=+$O(^PXRMXP(810.5,IEN)) Q:IEN=0  D
  1.  . S CREATOR=$P(^PXRMXP(810.5,IEN,0),U,7)
  1.  . S TYPE=$S(CREATOR="":"PUB",1:"PVT")
  1.  . S $P(^PXRMXP(810.5,IEN,0),U,8)=TYPE
  1.  Q
  1.  ;
  1.  ;==========================================
  1. SRSVC ;Save reminder report template service categories.
  1.  N CDATE,IEN,IND,PDATE,SVCL
  1.  D BMES^XPDUTL("Saving reminder report service categories")
  1.  S CDATE=$$NOW^XLFDT
  1.  S PDATE=$$FMADD^XLFDT(CDATE,30)
  1.  S ^XTMP("PXRMRSVC",0)=PDATE_U_CDATE_U_"SERVICE CATEGORIES"
  1.  S IEN=0
  1.  F  S IEN=+$O(^PXRMPT(810.1,IEN)) Q:IEN=0  D
  1.  . S SVCL="",IND=0
  1.  . F  S IND=+$O(^PXRMPT(810.1,IEN,8,IND)) Q:IND=0  D
  1.  .. I SVCL="" S SVCL=^PXRMPT(810.1,IEN,8,IND,0)
  1.  .. E  S SVCL=SVCL_","_^PXRMPT(810.1,IEN,8,IND,0)
  1.  . I SVCL'="" S ^XTMP("PXRMRSVC",IEN)=SVCL
  1.  Q
  1.  ;
  1.  ;==========================================
  1. SSPC ;Save the Sponsor classes.
  1.  N CDATE,CLASS,IEN,PDATE
  1.  D BMES^XPDUTL("Saving Sponsor Classes")
  1.  S CDATE=$$NOW^XLFDT
  1.  S PDATE=$$FMADD^XLFDT(CDATE,30)
  1.  S ^XTMP("PXRMSPCS",0)=PDATE_U_CDATE_U_"SPONSOR CLASSES"
  1.  S IEN=0
  1.  F  S IEN=+$O(^PXRMD(811.6,IEN)) Q:IEN=0  D
  1.  . S CLASS=$P(^PXRMD(811.6,IEN,0),U,2)
  1.  . S ^XTMP("PXRMSPCS",IEN)=CLASS
  1.  Q
  1.  ;