PXRMV2I ; SLC/PKR - Version 2.0 init routine. ;11/05/2004
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
Q
;
;===============================================================
CPCL ;Convert the internal patient cohort logic to the new form that
;includes sex and age.
N CPCL,IEN
S IEN=0
F S IEN=+$O(^PXD(811.9,IEN)) Q:IEN=0 D
. S CPCL=$G(^PXD(811.9,IEN,30))
. I CPCL'="" D CPPCLS^PXRMLOGX(IEN,CPCL)
. E D BLDPCLS^PXRMLOGX(IEN,"","")
Q
;
;===============================================================
CRXTYPE ;Convert the RXTYPE to the new form.
N FI,IND,RXTYPE
D BMES^XPDUTL("Converting definition RXTYPES to new form.")
S IEN=0
F S IEN=+$O(^PXD(811.9,IEN)) Q:IEN=0 D
. S FI=0
. F S FI=+$O(^PXD(811.9,IEN,20,FI)) Q:FI=0 D
.. S RXTYPE=$P(^PXD(811.9,IEN,20,FI,0),U,13)
.. I RXTYPE="B" S $P(^PXD(811.9,IEN,20,FI,0),U,13)="A"
D BMES^XPDUTL("Converting term RXTYPES to new form.")
S IEN=0
F S IEN=+$O(^PXRMD(811.5,IEN)) Q:IEN=0 D
. S FI=0
. F S FI=+$O(^PXRMD(811.5,IEN,20,FI)) Q:FI=0 D
.. S RXTYPE=$P(^PXRMD(811.5,IEN,20,FI,0),U,13)
.. I RXTYPE="B" S $P(^PXRMD(811.5,IEN,20,FI,0),U,13)="A"
Q
;
;===============================================================
CSVPE ;Execute the CSV protocol event points.
D ICDPE^PXRMCSPE
D CPTPE^PXRMCSPE
Q
;
;===============================================================
DELCF ;Delete erroneous computed finding entries.
N DA,DIK,NAME
S DIK="^PXRMD(811.4,"
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
. S DA=+$O(^PXRMD(811.4,"B",NAME,"")) Q:DA'>0
. D BMES^XPDUTL("Deleting Computed Finding: "_NAME)
. D ^DIK
Q
;
;===============================================================
DELDD ;Delete the old data dictionaries.
N DIU,TEXT
D EN^DDIOL("Removing old data dictionaries.")
S DIU(0)=""
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
. S TEXT=" Deleting data dictionary for file # "_DIU
. D EN^DDIOL(TEXT)
. D EN^DIU2
Q
;
;===============================================================
N DA,DIE,DR,NAME,PERIOD
S PERIOD="M1/2005",DIE="^PXRM(810.2,"
F NAME="VA-IHD QUERI","VA-MH QUERI" D
. S DA=$O(^PXRM(810.2,"B",NAME,"")) Q:DA'>0
. S DR="4///^S X=PERIOD" D ^DIE
Q
;
;===============================================================
FFFIX ;Clean up the function finding file at test sites.
N DA,DIK,NAME
S DIK="^PXRMD(802.4,"
F NAME="FND","FI","DUR" D
. S DA=+$O(^PXRMD(802.4,"B",NAME,"")) Q:DA'>0
. D BMES^XPDUTL("Deleting Function Finding: "_NAME)
. D ^DIK
Q
;
;===============================================================
FIXTERM ;
N IEN,TEMP0
S IEN=0 F S IEN=$O(^PXRMD(811.5,IEN)) Q:IEN'>0 D
. S TEMP0=$P($G(^PXRMD(811.5,IEN,0)),U,1,4)
. S $P(TEMP0,U,2)="",$P(TEMP0,U,3)=""
. S ^PXRMD(811.5,IEN,0)=TEMP0
Q
;
;===============================================================
FOMRD ;Flag all definitions using the old-style MRD.
N CPCL,IEN,NAME,NL,XMSUB
K ^TMP("PXRMXMZ",$J)
S XMSUB="Old-style MRD obsolete"
S ^TMP("PXRMXMZ",$J,1,0)="The old-style MRD function is obsolete and will be removed in a subsequent"
S ^TMP("PXRMXMZ",$J,2,0)="patch. Please do not use it anymore; use a function finding instead."
S ^TMP("PXRMXMZ",$J,3,0)="The following reminder definitions use the old-style MRD function;"
S ^TMP("PXRMXMZ",$J,4,0)="please change them to use a function finding."
S NL=4
S IEN=0
F S IEN=+$O(^PXD(811.9,IEN)) Q:IEN=0 D
. S CPCL=$G(^PXD(811.9,IEN,30))
. I CPCL'["MRD" Q
. S NAME=$P(^PXD(811.9,IEN,0),U,1)
. S NL=NL+1
. S ^TMP("PXRMXMZ",$J,NL,0)=" "
. S NL=NL+1
. S ^TMP("PXRMXMZ",$J,NL,0)="Reminder: "_NAME_", ien - "_IEN
. S NL=NL+1
. S ^TMP("PXRMXMZ",$J,NL,0)="Custom cohort logic: "_CPCL
I NL=4 K ^TMP("PXRMXMZ",$J,3,0),^TMP("PXRMXMZ",$J,4,0)
D SEND^PXRMMSG(XMSUB)
Q
;===============================================================
;
MAIL ;Add remote member to mail group IHD SEND
D ADDMBRS^XMXAPIG(DUZ,"IHD SEND","XXX@Q-IHD.MED.VA.GOV")
D ADDMBRS^XMXAPIG(DUZ,"IHD","S.HL MS SERVER")
D INIT^PXRMGECW
Q
;
;===============================================================
PRE ;
D RENAMIR
;D RENAMTRM
D DELCF
D FFFIX
D DELETE^PXRMV2IL
D DELEI^PXRMV2IE
D DELDD
Q
;
;===============================================================
POST ;
D SVRSN
D DELEXB^PXRMV2IE
D CNAK^PXRMV2IE
;D SMEXINS^PXRMV2IE
D FOMRD
D RTAXEXP
D MAIL
;D XPARAMS
D CPCL
D CEFFDATE^PXRMV2ID
D CFDATE^PXRMV2ID
D CSVPE
;D WEB
D COND^PXRMV2IC
D SFNFTC^PXRMV2IA
D DELGEC^PXRMV2IE
D EN^PXRMV2IR
D CRXTYPE^PXRMV2I
D FIXTERM
D EXTRACT
Q
;
;===============================================================
RENAMIR ;If the VA-IRAQ &AFGHAN POST-DEPLOY SCREEN reminder exists rename it.
N DA,DIE,DR,PXRMINST,TEXT
S DA=$O(^PXD(811.9,"B","VA-IRAQ &AFGHAN POST-DEPLOY SCREEN",""))
I DA="" Q
S TEXT="Renaming reminder VA-IRAQ &AFGHAN POST-DEPLOY SCREEN to VA-IRAQ & AFGHAN POST-DEPLOY SCREEN"
D BMES^XPDUTL(TEXT)
S DIE=811.9,DR=".01///VA-IRAQ & AFGHAN POST-DEPLOY SCREEN",PXRMINST=1
D ^DIE
Q
;
;===============================================================
RENAMTRM ;Rename all national terms so they start with VA-
N DA,DIE,DR,IEN,OLDNAME,NEWNAME,X
D BMES^XPDUTL("Renaming National Terms:")
S IEN=0 F S IEN=$O(^PXRMD(811.5,IEN)) Q:IEN'>0 D
. I $P($G(^PXRMD(811.5,IEN,100)),U)'="N" Q
. S OLDNAME=$P($G(^PXRMD(811.5,IEN,0)),U,1)
. I OLDNAME["VA-" Q
. D BMES^XPDUTL("Renaming Term: "_OLDNAME)
. S NEWNAME="VA-"_OLDNAME,DIE="^PXRMD(811.5,",DA=IEN,DR=".01///^S X=NEWNAME"
.;lock record
. L +^PXRMD(811.5,IEN):0 I $T D ^DIE L -^PXRMD(811.5,IEN)
S DIE="^PXRMD(811.4,"
S DA=$O(^PXRMD(811.4,"B","VA-IRAQ & AFGHAN SEP. DATE",""))
I $G(DA)="" Q
S DR=".01////VA-DISCHARGE DATE" D ^DIE
Q
;===============================================================
RTAXEXP ;Rebuild all taxonomy expansions.
N ALOW,AHIGH,FILENUM,HIGH,LOW,IEN,IND,TEMP,TEXT,X,X1,X2
S (X1,X2)="TAX"
D BMES^XPDUTL("Rebuilding taxonomy expansions and setting adjacent values.")
S IEN=0
F S IEN=+$O(^PXD(811.2,IEN)) Q:IEN=0 D
. S TEXT=" Working on taxonomy "_IEN
. D BMES^XPDUTL(TEXT)
. D DELEXTL^PXRMBXTL(IEN)
. D EXPAND^PXRMBXTL(IEN,"")
. F FILENUM=80,80.1,81 D
.. S IND=0
.. F S IND=+$O(^PXD(811.2,IEN,FILENUM,IND)) Q:IND=0 D
... S TEMP=^PXD(811.2,IEN,FILENUM,IND,0)
... S LOW=$P(TEMP,U,1),HIGH=$P(TEMP,U,2)
... S ALOW=$S(FILENUM=80:$$PREV^ICDAPIU(LOW),FILENUM=80.1:$$PREV^ICDAPIU(LOW),FILENUM=81:$$PREV^ICPTAPIU(LOW))
... S AHIGH=$S(FILENUM=80:$$NEXT^ICDAPIU(HIGH),FILENUM=80.1:$$NEXT^ICDAPIU(HIGH),FILENUM=81:$$NEXT^ICPTAPIU(HIGH))
... S $P(^PXD(811.2,IEN,FILENUM,IND,0),U,3,4)=ALOW_U_AHIGH
D BMES^XPDUTL(" DONE")
Q
;
;===============================================================
SENODE ;Rebuild the "E" index on definitions and terms.
;This code probably does not need to be run, keep it in case there
;is a problem at test sites.
N DA,DIK,IND,TEXT
S TEXT="Rebuilding E index for reminder definitions"
D BMES^XPDUTL(TEXT)
S IND=0
F S IND=+$O(^PXD(811.9,IND)) Q:IND=0 D
. S TEXT=" Working on reminder "_IND
. D BMES^XPDUTL(TEXT)
. K ^PXD(811.9,IND,20,"E")
. S DIK="^PXD(811.9,"_IND_",20,"
. S DA(1)=IND,DIK(1)=".01^E"
. D ENALL^DIK
S TEXT="Rebuilding E index for terms"
D BMES^XPDUTL(TEXT)
S IND=0
F S IND=+$O(^PXRMD(811.5,IND)) Q:IND=0 D
. S TEXT=" Working on term "_IND
. D BMES^XPDUTL(TEXT)
. K ^PXRMD(811.5,IND,20,"E")
. S DIK="^PXRMD(811.5,"_IND_",20,"
. S DA(1)=IND,DIK(1)=".01^E"
. D ENALL^DIK
Q
;
;===============================================================
SVRSN ;Set the package version number.
N VRSN
S VRSN=$P($T(+2^PXRM),";",3)
S ^PXRM(800,1,"VERSION")=VRSN
Q
;
;===============================================================
WEB ;Change the default web page from the prevention handbook
;to the oqp page.
N IND,NEW,OLD
S OLD="http://vaww.va.gov/publ/direc/health/handbook/1120-2hk.htm"
S NEW="http://www.oqp.med.va.gov/cpg/cpg.htm"
S IND=$O(^PXRM(800,1,1,"B",$E(OLD,1,30),""))
I IND="" Q
K ^PXRM(800,1,1,IND,0)
K ^PXRM(800,1,1,"B",$E(OLD,1,30),IND)
S ^PXRM(800,1,1,"B",$E(NEW,1,30),IND)=""
S $P(^PXRM(800,1,1,IND,0),U,1)=NEW
S $P(^PXRM(800,1,1,IND,0),U,2)="OQP Clinical Guidelines"
Q
;
;===============================================================
XPARAMS ;Set the next extract date in the IHD QUERI parameters
;
;Site must schedule extract with XU OPTION SCHEDULE option when ready
N IEN,LUVALUE
;
;IHD QUERI
S LUVALUE(1)="VA-IHD QUERI"
S IEN=+$$FIND1^DIC(810.2,"","KU",.LUVALUE)
;Update next extract period as current period
I IEN S $P(^PXRM(810.2,IEN,0),U,6)=$$PERIOD^PXRMEUT("M")
;
;MH QUERI
S LUVALUE(1)="VA-MH QUERI"
S IEN=+$$FIND1^DIC(810.2,"","KU",.LUVALUE)
;Update next extract period as current period
I IEN S $P(^PXRM(810.2,IEN,0),U,6)=$$PERIOD^PXRMEUT("M")
;
Q
;
PXRMV2I ; SLC/PKR - Version 2.0 init routine. ;11/05/2004
+1 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+2 QUIT
+3 ;
+4 ;===============================================================
CPCL ;Convert the internal patient cohort logic to the new form that
+1 ;includes sex and age.
+2 NEW CPCL,IEN
+3 SET IEN=0
+4 FOR
SET IEN=+$ORDER(^PXD(811.9,IEN))
IF IEN=0
QUIT
Begin DoDot:1
+5 SET CPCL=$GET(^PXD(811.9,IEN,30))
+6 IF CPCL'=""
DO CPPCLS^PXRMLOGX(IEN,CPCL)
+7 IF '$TEST
DO BLDPCLS^PXRMLOGX(IEN,"","")
End DoDot:1
+8 QUIT
+9 ;
+10 ;===============================================================
CRXTYPE ;Convert the RXTYPE to the new form.
+1 NEW FI,IND,RXTYPE
+2 DO BMES^XPDUTL("Converting definition RXTYPES to new form.")
+3 SET IEN=0
+4 FOR
SET IEN=+$ORDER(^PXD(811.9,IEN))
IF IEN=0
QUIT
Begin DoDot:1
+5 SET FI=0
+6 FOR
SET FI=+$ORDER(^PXD(811.9,IEN,20,FI))
IF FI=0
QUIT
Begin DoDot:2
+7 SET RXTYPE=$PIECE(^PXD(811.9,IEN,20,FI,0),U,13)
+8 IF RXTYPE="B"
SET $PIECE(^PXD(811.9,IEN,20,FI,0),U,13)="A"
End DoDot:2
End DoDot:1
+9 DO BMES^XPDUTL("Converting term RXTYPES to new form.")
+10 SET IEN=0
+11 FOR
SET IEN=+$ORDER(^PXRMD(811.5,IEN))
IF IEN=0
QUIT
Begin DoDot:1
+12 SET FI=0
+13 FOR
SET FI=+$ORDER(^PXRMD(811.5,IEN,20,FI))
IF FI=0
QUIT
Begin DoDot:2
+14 SET RXTYPE=$PIECE(^PXRMD(811.5,IEN,20,FI,0),U,13)
+15 IF RXTYPE="B"
SET $PIECE(^PXRMD(811.5,IEN,20,FI,0),U,13)="A"
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
+18 ;===============================================================
CSVPE ;Execute the CSV protocol event points.
+1 DO ICDPE^PXRMCSPE
+2 DO CPTPE^PXRMCSPE
+3 QUIT
+4 ;
+5 ;===============================================================
DELCF ;Delete erroneous computed finding entries.
+1 NEW DA,DIK,NAME
+2 SET DIK="^PXRMD(811.4,"
+3 FOR 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"
Begin DoDot:1
+4 SET DA=+$ORDER(^PXRMD(811.4,"B",NAME,""))
IF DA'>0
QUIT
+5 DO BMES^XPDUTL("Deleting Computed Finding: "_NAME)
+6 DO ^DIK
End DoDot:1
+7 QUIT
+8 ;
+9 ;===============================================================
DELDD ;Delete the old data dictionaries.
+1 NEW DIU,TEXT
+2 DO EN^DDIOL("Removing old data dictionaries.")
+3 SET DIU(0)=""
+4 FOR 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
Begin DoDot:1
+5 SET TEXT=" Deleting data dictionary for file # "_DIU
+6 DO EN^DDIOL(TEXT)
+7 DO EN^DIU2
End DoDot:1
+8 QUIT
+9 ;
+10 ;===============================================================
+1 NEW DA,DIE,DR,NAME,PERIOD
+2 SET PERIOD="M1/2005"
SET DIE="^PXRM(810.2,"
+3 FOR NAME="VA-IHD QUERI","VA-MH QUERI"
Begin DoDot:1
+4 SET DA=$ORDER(^PXRM(810.2,"B",NAME,""))
IF DA'>0
QUIT
+5 SET DR="4///^S X=PERIOD"
DO ^DIE
End DoDot:1
+6 QUIT
+7 ;
+8 ;===============================================================
FFFIX ;Clean up the function finding file at test sites.
+1 NEW DA,DIK,NAME
+2 SET DIK="^PXRMD(802.4,"
+3 FOR NAME="FND","FI","DUR"
Begin DoDot:1
+4 SET DA=+$ORDER(^PXRMD(802.4,"B",NAME,""))
IF DA'>0
QUIT
+5 DO BMES^XPDUTL("Deleting Function Finding: "_NAME)
+6 DO ^DIK
End DoDot:1
+7 QUIT
+8 ;
+9 ;===============================================================
FIXTERM ;
+1 NEW IEN,TEMP0
+2 SET IEN=0
FOR
SET IEN=$ORDER(^PXRMD(811.5,IEN))
IF IEN'>0
QUIT
Begin DoDot:1
+3 SET TEMP0=$PIECE($GET(^PXRMD(811.5,IEN,0)),U,1,4)
+4 SET $PIECE(TEMP0,U,2)=""
SET $PIECE(TEMP0,U,3)=""
+5 SET ^PXRMD(811.5,IEN,0)=TEMP0
End DoDot:1
+6 QUIT
+7 ;
+8 ;===============================================================
FOMRD ;Flag all definitions using the old-style MRD.
+1 NEW CPCL,IEN,NAME,NL,XMSUB
+2 KILL ^TMP("PXRMXMZ",$JOB)
+3 SET XMSUB="Old-style MRD obsolete"
+4 SET ^TMP("PXRMXMZ",$JOB,1,0)="The old-style MRD function is obsolete and will be removed in a subsequent"
+5 SET ^TMP("PXRMXMZ",$JOB,2,0)="patch. Please do not use it anymore; use a function finding instead."
+6 SET ^TMP("PXRMXMZ",$JOB,3,0)="The following reminder definitions use the old-style MRD function;"
+7 SET ^TMP("PXRMXMZ",$JOB,4,0)="please change them to use a function finding."
+8 SET NL=4
+9 SET IEN=0
+10 FOR
SET IEN=+$ORDER(^PXD(811.9,IEN))
IF IEN=0
QUIT
Begin DoDot:1
+11 SET CPCL=$GET(^PXD(811.9,IEN,30))
+12 IF CPCL'["MRD"
QUIT
+13 SET NAME=$PIECE(^PXD(811.9,IEN,0),U,1)
+14 SET NL=NL+1
+15 SET ^TMP("PXRMXMZ",$JOB,NL,0)=" "
+16 SET NL=NL+1
+17 SET ^TMP("PXRMXMZ",$JOB,NL,0)="Reminder: "_NAME_", ien - "_IEN
+18 SET NL=NL+1
+19 SET ^TMP("PXRMXMZ",$JOB,NL,0)="Custom cohort logic: "_CPCL
End DoDot:1
+20 IF NL=4
KILL ^TMP("PXRMXMZ",$JOB,3,0),^TMP("PXRMXMZ",$JOB,4,0)
+21 DO SEND^PXRMMSG(XMSUB)
+22 QUIT
+23 ;===============================================================
+24 ;
MAIL ;Add remote member to mail group IHD SEND
+1 DO ADDMBRS^XMXAPIG(DUZ,"IHD SEND","XXX@Q-IHD.MED.VA.GOV")
+2 DO ADDMBRS^XMXAPIG(DUZ,"IHD","S.HL MS SERVER")
+3 DO INIT^PXRMGECW
+4 QUIT
+5 ;
+6 ;===============================================================
PRE ;
+1 DO RENAMIR
+2 ;D RENAMTRM
+3 DO DELCF
+4 DO FFFIX
+5 DO DELETE^PXRMV2IL
+6 DO DELEI^PXRMV2IE
+7 DO DELDD
+8 QUIT
+9 ;
+10 ;===============================================================
POST ;
+1 DO SVRSN
+2 DO DELEXB^PXRMV2IE
+3 DO CNAK^PXRMV2IE
+4 ;D SMEXINS^PXRMV2IE
+5 DO FOMRD
+6 DO RTAXEXP
+7 DO MAIL
+8 ;D XPARAMS
+9 DO CPCL
+10 DO CEFFDATE^PXRMV2ID
+11 DO CFDATE^PXRMV2ID
+12 DO CSVPE
+13 ;D WEB
+14 DO COND^PXRMV2IC
+15 DO SFNFTC^PXRMV2IA
+16 DO DELGEC^PXRMV2IE
+17 DO EN^PXRMV2IR
+18 DO CRXTYPE^PXRMV2I
+19 DO FIXTERM
+20 DO EXTRACT
+21 QUIT
+22 ;
+23 ;===============================================================
RENAMIR ;If the VA-IRAQ &AFGHAN POST-DEPLOY SCREEN reminder exists rename it.
+1 NEW DA,DIE,DR,PXRMINST,TEXT
+2 SET DA=$ORDER(^PXD(811.9,"B","VA-IRAQ &AFGHAN POST-DEPLOY SCREEN",""))
+3 IF DA=""
QUIT
+4 SET TEXT="Renaming reminder VA-IRAQ &AFGHAN POST-DEPLOY SCREEN to VA-IRAQ & AFGHAN POST-DEPLOY SCREEN"
+5 DO BMES^XPDUTL(TEXT)
+6 SET DIE=811.9
SET DR=".01///VA-IRAQ & AFGHAN POST-DEPLOY SCREEN"
SET PXRMINST=1
+7 DO ^DIE
+8 QUIT
+9 ;
+10 ;===============================================================
RENAMTRM ;Rename all national terms so they start with VA-
+1 NEW DA,DIE,DR,IEN,OLDNAME,NEWNAME,X
+2 DO BMES^XPDUTL("Renaming National Terms:")
+3 SET IEN=0
FOR
SET IEN=$ORDER(^PXRMD(811.5,IEN))
IF IEN'>0
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^PXRMD(811.5,IEN,100)),U)'="N"
QUIT
+5 SET OLDNAME=$PIECE($GET(^PXRMD(811.5,IEN,0)),U,1)
+6 IF OLDNAME["VA-"
QUIT
+7 DO BMES^XPDUTL("Renaming Term: "_OLDNAME)
+8 SET NEWNAME="VA-"_OLDNAME
SET DIE="^PXRMD(811.5,"
SET DA=IEN
SET DR=".01///^S X=NEWNAME"
+9 ;lock record
+10 LOCK +^PXRMD(811.5,IEN):0
IF $TEST
DO ^DIE
LOCK -^PXRMD(811.5,IEN)
End DoDot:1
+11 SET DIE="^PXRMD(811.4,"
+12 SET DA=$ORDER(^PXRMD(811.4,"B","VA-IRAQ & AFGHAN SEP. DATE",""))
+13 IF $GET(DA)=""
QUIT
+14 SET DR=".01////VA-DISCHARGE DATE"
DO ^DIE
+15 QUIT
+16 ;===============================================================
RTAXEXP ;Rebuild all taxonomy expansions.
+1 NEW ALOW,AHIGH,FILENUM,HIGH,LOW,IEN,IND,TEMP,TEXT,X,X1,X2
+2 SET (X1,X2)="TAX"
+3 DO BMES^XPDUTL("Rebuilding taxonomy expansions and setting adjacent values.")
+4 SET IEN=0
+5 FOR
SET IEN=+$ORDER(^PXD(811.2,IEN))
IF IEN=0
QUIT
Begin DoDot:1
+6 SET TEXT=" Working on taxonomy "_IEN
+7 DO BMES^XPDUTL(TEXT)
+8 DO DELEXTL^PXRMBXTL(IEN)
+9 DO EXPAND^PXRMBXTL(IEN,"")
+10 FOR FILENUM=80,80.1,81
Begin DoDot:2
+11 SET IND=0
+12 FOR
SET IND=+$ORDER(^PXD(811.2,IEN,FILENUM,IND))
IF IND=0
QUIT
Begin DoDot:3
+13 SET TEMP=^PXD(811.2,IEN,FILENUM,IND,0)
+14 SET LOW=$PIECE(TEMP,U,1)
SET HIGH=$PIECE(TEMP,U,2)
+15 SET ALOW=$SELECT(FILENUM=80:$$PREV^ICDAPIU(LOW),FILENUM=80.1:$$PREV^ICDAPIU(LOW),FILENUM=81:$$PREV^ICPTAPIU(LOW))
+16 SET AHIGH=$SELECT(FILENUM=80:$$NEXT^ICDAPIU(HIGH),FILENUM=80.1:$$NEXT^ICDAPIU(HIGH),FILENUM=81:$$NEXT^ICPTAPIU(HIGH))
+17 SET $PIECE(^PXD(811.2,IEN,FILENUM,IND,0),U,3,4)=ALOW_U_AHIGH
End DoDot:3
End DoDot:2
End DoDot:1
+18 DO BMES^XPDUTL(" DONE")
+19 QUIT
+20 ;
+21 ;===============================================================
SENODE ;Rebuild the "E" index on definitions and terms.
+1 ;This code probably does not need to be run, keep it in case there
+2 ;is a problem at test sites.
+3 NEW DA,DIK,IND,TEXT
+4 SET TEXT="Rebuilding E index for reminder definitions"
+5 DO BMES^XPDUTL(TEXT)
+6 SET IND=0
+7 FOR
SET IND=+$ORDER(^PXD(811.9,IND))
IF IND=0
QUIT
Begin DoDot:1
+8 SET TEXT=" Working on reminder "_IND
+9 DO BMES^XPDUTL(TEXT)
+10 KILL ^PXD(811.9,IND,20,"E")
+11 SET DIK="^PXD(811.9,"_IND_",20,"
+12 SET DA(1)=IND
SET DIK(1)=".01^E"
+13 DO ENALL^DIK
End DoDot:1
+14 SET TEXT="Rebuilding E index for terms"
+15 DO BMES^XPDUTL(TEXT)
+16 SET IND=0
+17 FOR
SET IND=+$ORDER(^PXRMD(811.5,IND))
IF IND=0
QUIT
Begin DoDot:1
+18 SET TEXT=" Working on term "_IND
+19 DO BMES^XPDUTL(TEXT)
+20 KILL ^PXRMD(811.5,IND,20,"E")
+21 SET DIK="^PXRMD(811.5,"_IND_",20,"
+22 SET DA(1)=IND
SET DIK(1)=".01^E"
+23 DO ENALL^DIK
End DoDot:1
+24 QUIT
+25 ;
+26 ;===============================================================
SVRSN ;Set the package version number.
+1 NEW VRSN
+2 SET VRSN=$PIECE($TEXT(+2^PXRM),";",3)
+3 SET ^PXRM(800,1,"VERSION")=VRSN
+4 QUIT
+5 ;
+6 ;===============================================================
WEB ;Change the default web page from the prevention handbook
+1 ;to the oqp page.
+2 NEW IND,NEW,OLD
+3 SET OLD="http://vaww.va.gov/publ/direc/health/handbook/1120-2hk.htm"
+4 SET NEW="http://www.oqp.med.va.gov/cpg/cpg.htm"
+5 SET IND=$ORDER(^PXRM(800,1,1,"B",$EXTRACT(OLD,1,30),""))
+6 IF IND=""
QUIT
+7 KILL ^PXRM(800,1,1,IND,0)
+8 KILL ^PXRM(800,1,1,"B",$EXTRACT(OLD,1,30),IND)
+9 SET ^PXRM(800,1,1,"B",$EXTRACT(NEW,1,30),IND)=""
+10 SET $PIECE(^PXRM(800,1,1,IND,0),U,1)=NEW
+11 SET $PIECE(^PXRM(800,1,1,IND,0),U,2)="OQP Clinical Guidelines"
+12 QUIT
+13 ;
+14 ;===============================================================
XPARAMS ;Set the next extract date in the IHD QUERI parameters
+1 ;
+2 ;Site must schedule extract with XU OPTION SCHEDULE option when ready
+3 NEW IEN,LUVALUE
+4 ;
+5 ;IHD QUERI
+6 SET LUVALUE(1)="VA-IHD QUERI"
+7 SET IEN=+$$FIND1^DIC(810.2,"","KU",.LUVALUE)
+8 ;Update next extract period as current period
+9 IF IEN
SET $PIECE(^PXRM(810.2,IEN,0),U,6)=$$PERIOD^PXRMEUT("M")
+10 ;
+11 ;MH QUERI
+12 SET LUVALUE(1)="VA-MH QUERI"
+13 SET IEN=+$$FIND1^DIC(810.2,"","KU",.LUVALUE)
+14 ;Update next extract period as current period
+15 IF IEN
SET $PIECE(^PXRM(810.2,IEN,0),U,6)=$$PERIOD^PXRMEUT("M")
+16 ;
+17 QUIT
+18 ;
