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

PXRMV2I.m

Go to the documentation of this file. 
  1. PXRMV2I ; SLC/PKR - Version 2.0 init routine. ;11/05/2004
  1.  ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  1.  Q
  1.  ;
  1.  ;===============================================================
  1. CPCL ;Convert the internal patient cohort logic to the new form that
  1.  ;includes sex and age.
  1.  N CPCL,IEN
  1.  S IEN=0
  1.  F  S IEN=+$O(^PXD(811.9,IEN)) Q:IEN=0  D
  1.  . S CPCL=$G(^PXD(811.9,IEN,30))
  1.  . I CPCL'="" D CPPCLS^PXRMLOGX(IEN,CPCL)
  1.  . E  D BLDPCLS^PXRMLOGX(IEN,"","")
  1.  Q
  1.  ;
  1.  ;===============================================================
  1. CRXTYPE ;Convert the RXTYPE to the new form.
  1.  N FI,IND,RXTYPE
  1.  D BMES^XPDUTL("Converting definition RXTYPES to new form.")
  1.  S IEN=0
  1.  F  S IEN=+$O(^PXD(811.9,IEN)) Q:IEN=0  D
  1.  . S FI=0
  1.  . F  S FI=+$O(^PXD(811.9,IEN,20,FI)) Q:FI=0  D
  1.  .. S RXTYPE=$P(^PXD(811.9,IEN,20,FI,0),U,13)
  1.  .. I RXTYPE="B" S $P(^PXD(811.9,IEN,20,FI,0),U,13)="A"
  1.  D BMES^XPDUTL("Converting term RXTYPES to new form.")
  1.  S IEN=0
  1.  F  S IEN=+$O(^PXRMD(811.5,IEN)) Q:IEN=0  D
  1.  . S FI=0
  1.  . F  S FI=+$O(^PXRMD(811.5,IEN,20,FI)) Q:FI=0  D
  1.  .. S RXTYPE=$P(^PXRMD(811.5,IEN,20,FI,0),U,13)
  1.  .. I RXTYPE="B" S $P(^PXRMD(811.5,IEN,20,FI,0),U,13)="A"
  1.  Q
  1.  ;
  1.  ;===============================================================
  1. CSVPE ;Execute the CSV protocol event points.
  1.  D ICDPE^PXRMCSPE
  1.  D CPTPE^PXRMCSPE
  1.  Q
  1.  ;
  1.  ;===============================================================
  1. DELCF ;Delete erroneous computed finding entries.
  1.  N DA,DIK,NAME
  1.  S DIK="^PXRMD(811.4,"
  1.  F NAME="VA-WH MAMMOGRAM REV IN WH PKG","VA-WH PAP SMEAR REV IN WH PKG","VA-WH REVIEW OR RESULT","VA-WH ULTRASOUND","VA-WH ULTRASOUND REVIEW" D
  1.  . S DA=+$O(^PXRMD(811.4,"B",NAME,"")) Q:DA'>0
  1.  . D BMES^XPDUTL("Deleting Computed Finding: "_NAME)
  1.  . D ^DIK
  1.  Q
  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.3,801.41,801.42,801.43,801.45,801.5,801.9,801.95,802.4,810.1,810.2,810.3,810.4,810.5,810.6,810.7,810.8,810.9,811.2,811.3,811.4,811.5,811.6,811.7,811.8,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. EXTRACT ;
  1.  N DA,DIE,DR,NAME,PERIOD
  1.  S PERIOD="M1/2005",DIE="^PXRM(810.2,"
  1.  F NAME="VA-IHD QUERI","VA-MH QUERI" D
  1.  . S DA=$O(^PXRM(810.2,"B",NAME,"")) Q:DA'>0
  1.  . S DR="4///^S X=PERIOD" D ^DIE
  1.  Q
  1.  ;
  1.  ;===============================================================
  1. FFFIX ;Clean up the function finding file at test sites.
  1.  N DA,DIK,NAME
  1.  S DIK="^PXRMD(802.4,"
  1.  F NAME="FND","FI","DUR" D
  1.  . S DA=+$O(^PXRMD(802.4,"B",NAME,"")) Q:DA'>0
  1.  . D BMES^XPDUTL("Deleting Function Finding: "_NAME)
  1.  . D ^DIK
  1.  Q
  1.  ;
  1.  ;===============================================================
  1. FIXTERM ;
  1.  N IEN,TEMP0
  1.  S IEN=0 F  S IEN=$O(^PXRMD(811.5,IEN)) Q:IEN'>0  D
  1.  . S TEMP0=$P($G(^PXRMD(811.5,IEN,0)),U,1,4)
  1.  . S $P(TEMP0,U,2)="",$P(TEMP0,U,3)=""
  1.  . S ^PXRMD(811.5,IEN,0)=TEMP0
  1.  Q
  1.  ;
  1.  ;===============================================================
  1. FOMRD ;Flag all definitions using the old-style MRD.
  1.  N CPCL,IEN,NAME,NL,XMSUB
  1.  K ^TMP("PXRMXMZ",$J)
  1.  S XMSUB="Old-style MRD obsolete"
  1.  S ^TMP("PXRMXMZ",$J,1,0)="The old-style MRD function is obsolete and will be removed in a subsequent"
  1.  S ^TMP("PXRMXMZ",$J,2,0)="patch. Please do not use it anymore; use a function finding instead."
  1.  S ^TMP("PXRMXMZ",$J,3,0)="The following reminder definitions use the old-style MRD function;"
  1.  S ^TMP("PXRMXMZ",$J,4,0)="please change them to use a function finding."
  1.  S NL=4
  1.  S IEN=0
  1.  F  S IEN=+$O(^PXD(811.9,IEN)) Q:IEN=0  D
  1.  . S CPCL=$G(^PXD(811.9,IEN,30))
  1.  . I CPCL'["MRD" Q
  1.  . S NAME=$P(^PXD(811.9,IEN,0),U,1)
  1.  . S NL=NL+1
  1.  . S ^TMP("PXRMXMZ",$J,NL,0)=" "
  1.  . S NL=NL+1
  1.  . S ^TMP("PXRMXMZ",$J,NL,0)="Reminder: "_NAME_", ien - "_IEN
  1.  . S NL=NL+1
  1.  . S ^TMP("PXRMXMZ",$J,NL,0)="Custom cohort logic: "_CPCL
  1.  I NL=4 K ^TMP("PXRMXMZ",$J,3,0),^TMP("PXRMXMZ",$J,4,0)
  1.  D SEND^PXRMMSG(XMSUB)
  1.  Q
  1.  ;===============================================================
  1.  ;
  1. MAIL ;Add remote member to mail group IHD SEND
  1.  D ADDMBRS^XMXAPIG(DUZ,"IHD SEND","XXX@Q-IHD.DOMAIN.EXT")
  1.  D ADDMBRS^XMXAPIG(DUZ,"IHD","S.HL MS SERVER")
  1.  D INIT^PXRMGECW
  1.  Q
  1.  ;
  1.  ;===============================================================
  1. PRE ;
  1.  D RENAMIR
  1.  D RENAMTRM
  1.  D DELCF
  1.  D FFFIX
  1.  D DELETE^PXRMV2IL
  1.  D DELEI^PXRMV2IE
  1.  D DELDD
  1.  Q
  1.  ;
  1.  ;===============================================================
  1. POST ;
  1.  D SVRSN
  1.  D DELEXB^PXRMV2IE
  1.  D CNAK^PXRMV2IE
  1.  D SMEXINS^PXRMV2IE
  1.  D FOMRD
  1.  D RTAXEXP
  1.  D MAIL
  1.  ;D XPARAMS
  1.  D CPCL
  1.  D CEFFDATE^PXRMV2ID
  1.  D CFDATE^PXRMV2ID
  1.  D CSVPE
  1.  D WEB
  1.  D COND^PXRMV2IC
  1.  D SFNFTC^PXRMV2IA
  1.  D DELGEC^PXRMV2IE
  1.  D EN^PXRMV2IR
  1.  D CRXTYPE^PXRMV2I
  1.  D FIXTERM
  1.  D EXTRACT
  1.  Q
  1.  ;
  1.  ;===============================================================
  1. RENAMIR ;If the VA-IRAQ &AFGHAN POST-DEPLOY SCREEN reminder exists rename it.
  1.  N DA,DIE,DR,PXRMINST,TEXT
  1.  S DA=$O(^PXD(811.9,"B","VA-IRAQ &AFGHAN POST-DEPLOY SCREEN",""))
  1.  I DA="" Q
  1.  S TEXT="Renaming reminder VA-IRAQ &AFGHAN POST-DEPLOY SCREEN to VA-IRAQ & AFGHAN POST-DEPLOY SCREEN"
  1.  D BMES^XPDUTL(TEXT)
  1.  S DIE=811.9,DR=".01///VA-IRAQ & AFGHAN POST-DEPLOY SCREEN",PXRMINST=1
  1.  D ^DIE
  1.  Q
  1.  ;
  1.  ;===============================================================
  1. RENAMTRM ;Rename all national terms so they start with VA-
  1.  N DA,DIE,DR,IEN,OLDNAME,NEWNAME,X
  1.  D BMES^XPDUTL("Renaming National Terms:")
  1.  S IEN=0 F  S IEN=$O(^PXRMD(811.5,IEN)) Q:IEN'>0  D
  1.  . I $P($G(^PXRMD(811.5,IEN,100)),U)'="N" Q
  1.  . S OLDNAME=$P($G(^PXRMD(811.5,IEN,0)),U,1)
  1.  . I OLDNAME["VA-" Q
  1.  . D BMES^XPDUTL("Renaming Term: "_OLDNAME)
  1.  . S NEWNAME="VA-"_OLDNAME,DIE="^PXRMD(811.5,",DA=IEN,DR=".01///^S X=NEWNAME"
  1.  .;lock record
  1.  . L +^PXRMD(811.5,IEN):0 I $T D ^DIE L -^PXRMD(811.5,IEN)
  1.  S DIE="^PXRMD(811.4,"
  1.  S DA=$O(^PXRMD(811.4,"B","VA-IRAQ & AFGHAN SEP. DATE",""))
  1.  I $G(DA)="" Q
  1.  S DR=".01////VA-DISCHARGE DATE" D ^DIE
  1.  Q
  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=0
  1.  F  S IEN=+$O(^PXD(811.2,IEN)) Q:IEN=0  D
  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. SENODE ;Rebuild the "E" index on definitions and terms.
  1.  ;This code probably does not need to be run, keep it in case there
  1.  ;is a problem at test sites.
  1.  N DA,DIK,IND,TEXT
  1.  S TEXT="Rebuilding E index for reminder definitions"
  1.  D BMES^XPDUTL(TEXT)
  1.  S IND=0
  1.  F  S IND=+$O(^PXD(811.9,IND)) Q:IND=0  D
  1.  . S TEXT=" Working on reminder "_IND
  1.  . D BMES^XPDUTL(TEXT)
  1.  . K ^PXD(811.9,IND,20,"E")
  1.  . S DIK="^PXD(811.9,"_IND_",20,"
  1.  . S DA(1)=IND,DIK(1)=".01^E"
  1.  . D ENALL^DIK
  1.  S TEXT="Rebuilding E index for terms"
  1.  D BMES^XPDUTL(TEXT)
  1.  S IND=0
  1.  F  S IND=+$O(^PXRMD(811.5,IND)) Q:IND=0  D
  1.  . S TEXT=" Working on term "_IND
  1.  . D BMES^XPDUTL(TEXT)
  1.  . K ^PXRMD(811.5,IND,20,"E")
  1.  . S DIK="^PXRMD(811.5,"_IND_",20,"
  1.  . S DA(1)=IND,DIK(1)=".01^E"
  1.  . D ENALL^DIK
  1.  Q
  1.  ;
  1.  ;===============================================================
  1. SVRSN ;Set the package version number.
  1.  N VRSN
  1.  S VRSN=$P($T(+2^PXRM),";",3)
  1.  S ^PXRM(800,1,"VERSION")=VRSN
  1.  Q
  1.  ;
  1.  ;===============================================================
  1. WEB ;Change the default web page from the prevention handbook
  1.  ;to the oqp page.
  1.  N IND,NEW,OLD
  1.  S OLD="http://vaww.domain.ext/publ/direc/health/handbook/1120-2hk.htm"
  1.  S NEW="http://www.oqp.domain.ext/cpg/cpg.htm"
  1.  S IND=$O(^PXRM(800,1,1,"B",$E(OLD,1,30),""))
  1.  I IND="" Q
  1.  K ^PXRM(800,1,1,IND,0)
  1.  K ^PXRM(800,1,1,"B",$E(OLD,1,30),IND)
  1.  S ^PXRM(800,1,1,"B",$E(NEW,1,30),IND)=""
  1.  S $P(^PXRM(800,1,1,IND,0),U,1)=NEW
  1.  S $P(^PXRM(800,1,1,IND,0),U,2)="OQP Clinical Guidelines"
  1.  Q
  1.  ;
  1.  ;===============================================================
  1. XPARAMS ;Set the next extract date in the IHD QUERI parameters
  1.  ;
  1.  ;Site must schedule extract with XU OPTION SCHEDULE option when ready
  1.  N IEN,LUVALUE
  1.  ;
  1.  ;IHD QUERI
  1.  S LUVALUE(1)="VA-IHD QUERI"
  1.  S IEN=+$$FIND1^DIC(810.2,"","KU",.LUVALUE)
  1.  ;Update next extract period as current period
  1.  I IEN S $P(^PXRM(810.2,IEN,0),U,6)=$$PERIOD^PXRMEUT("M")
  1.  ;
  1.  ;MH QUERI
  1.  S LUVALUE(1)="VA-MH QUERI"
  1.  S IEN=+$$FIND1^DIC(810.2,"","KU",.LUVALUE)
  1.  ;Update next extract period as current period
  1.  I IEN S $P(^PXRM(810.2,IEN,0),U,6)=$$PERIOD^PXRMEUT("M")
  1.  ;
  1.  Q
  1.  ;