PXRMP5I ; SLC/AGP - Patch 5 init routine. ;09/16/2005
;;2.0;CLINICAL REMINDERS;**5**;Feb 04, 2005
;Reminder Exchange install.
Q
;
;===============================================================
ARRAY(MODE,ARRAY) ;List of exchange entries used by delete and install
;
S ARRAY(1,1)="VA-IRAQ & AFGHAN POST-DEPLOY SCREEN"
I MODE S ARRAY(1,2)="09/20/2005@10:35:40"
Q
;
;===============================================================
DELDD ;Delete the old data dictionaries.
N DIU,TEXT
D EN^DDIOL("Removing old data dictionaries.")
S DIU(0)=""
S DIU=811.6
S TEXT=" Deleting data dictionary for file # "_DIU
D EN^DDIOL(TEXT)
D EN^DIU2
Q
;===============================================================
DELEI ;If the Exchange File entry already exists delete it.
N ARRAY,IC,IND,LIST,LUVALUE,NUM
D ARRAY(1,.ARRAY)
S IC=0
F S IC=$O(ARRAY(IC)) Q:'IC D
.S LUVALUE(1)=ARRAY(IC,1)
.D FIND^DIC(811.8,"","","U",.LUVALUE,"","","","","LIST")
.I '$D(LIST) Q
.S NUM=$P(LIST("DILIST",0),U,1)
.I NUM'=0 D
..F IND=1:1:NUM D
... N DA,DIK
... S DIK="^PXD(811.8,"
... S DA=LIST("DILIST",2,IND)
... D ^DIK
Q
;
;===============================================================
EXFINC(Y) ;Return a 1 if the Exchange file entry is in the list to
;include in the build. This is used in the build to determine which
;entries to include.
N ARRAY,FOUND,IEN,IC,LUVALUE
D ARRAY(1,.ARRAY)
S FOUND=0
S IC=0
F S IC=+$O(ARRAY(IC)) Q:(IC=0)!(FOUND) D
. M LUVALUE=ARRAY(IC)
. S IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
. I IEN=Y S FOUND=1 Q
Q FOUND
;
PRE ;
D SSPC
D DELDD
D DELEI
Q
POST ;
D RSPC
;D SMEXINS
Q
;===============================================================
RSPC ;Restore the sponser classes to the new location.
N ARRAY,CLASS,IEN,NAME,TEMP
S ARRAY("INFECTIOUS DISEASES PROGRAM OFFICE, VAHQ")="N"
S ARRAY("JOHN D DEMAKIS")="N"
S ARRAY("Mental Health and Behavioral Science Strategic Group")="N"
S ARRAY("Mental Health and Behavioral Science Strategic Group and Women Veterans Health Program")="N"
S ARRAY("National Clinical Practice Guideline Council")="N"
S ARRAY("Office of Geriatric Extended Care")="N"
S ARRAY("Office of Public Health and Environmental Hazards")="N"
S ARRAY("Office of Quality & Performance")="N"
S ARRAY("Women Veterans Health Program")="N"
D BMES^XPDUTL("Restoring Sponsor Classes")
S IEN=0
F S IEN=+$O(^XTMP("PXRMSPCS",IEN)) Q:IEN=0 D
. S CLASS=^XTMP("PXRMSPCS",IEN)
. S $P(^PXRMD(811.6,IEN,100),U,1)=CLASS
S IEN=0
F S IEN=$O(^PXRMD(811.6,IEN)) Q:IEN'>0 D
. S CLASS=$P($G(^PXRMD(811.6,IEN,100)),U)
. I CLASS="" D
. .S TEMP=$P($G(^PXRMD(811.6,IEN,0)),U,2)
. .S NAME=$P($G(^PXRMD(811.6,IEN,0)),U) Q:NAME=""
. .I TEMP="" S TEMP=$S($D(ARRAY(NAME))>0:ARRAY(NAME),1:"L")
. .S $P(^PXRMD(811.6,IEN,100),U)=TEMP,CLASS=TEMP
. I CLASS'="" D
. .S TEMP=^PXRMD(811.6,IEN,0)
. .S ^PXRMD(811.6,IEN,0)=$P(TEMP,U)
Q
;===============================================================
SMEXINS ;Silent mode install.
N ARRAY,IC,IEN,LUVALUE,PXRMINST
S PXRMINST=1
D ARRAY(1,.ARRAY)
S IC=0
F S IC=$O(ARRAY(IC)) Q:'IC D
.M LUVALUE=ARRAY(IC)
.S IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
.I IEN'=0 D
.. N TEXT
.. I LUVALUE(1)["PARAMETER" S TEXT="Installing entry "_LUVALUE(1)
.. E S TEXT="Installing reminder "_LUVALUE(1)
.. D BMES^XPDUTL(TEXT)
.. D INSTALL^PXRMEXSI(IEN,1)
Q
;
;===============================================================
SSPC ;Save the Sponsor classes.
N CDATE,CLASS,IEN,PDATE
D BMES^XPDUTL("Saving Sponsor Classes")
S CDATE=$$NOW^XLFDT
S PDATE=$$FMADD^XLFDT(CDATE,30)
S ^XTMP("PXRMSPCS",0)=PDATE_U_CDATE_U_"SPONSOR CLASSES"
S IEN=0
F S IEN=+$O(^PXRMD(811.6,IEN)) Q:IEN=0 D
. S CLASS=$P($G(^PXRMD(811.6,IEN,0)),U,2)
. ;CHECK FOR TEST SITES
. I $G(CLASS)="" S CLASS=$P($G(^PXRMD(811.6,IEN,100)),U)
. S ^XTMP("PXRMSPCS",IEN)=CLASS
Q
PXRMP5I ; SLC/AGP - Patch 5 init routine. ;09/16/2005
+1 ;;2.0;CLINICAL REMINDERS;**5**;Feb 04, 2005
+2 ;Reminder Exchange install.
+3 QUIT
+4 ;
+5 ;===============================================================
ARRAY(MODE,ARRAY) ;List of exchange entries used by delete and install
+1 ;
+2 SET ARRAY(1,1)="VA-IRAQ & AFGHAN POST-DEPLOY SCREEN"
+3 IF MODE
SET ARRAY(1,2)="09/20/2005@10:35:40"
+4 QUIT
+5 ;
+6 ;===============================================================
DELDD ;Delete the old data dictionaries.
+1 NEW DIU,TEXT
+2 DO EN^DDIOL("Removing old data dictionaries.")
+3 SET DIU(0)=""
+4 SET DIU=811.6
+5 SET TEXT=" Deleting data dictionary for file # "_DIU
+6 DO EN^DDIOL(TEXT)
+7 DO EN^DIU2
+8 QUIT
+9 ;===============================================================
DELEI ;If the Exchange File entry already exists delete it.
+1 NEW ARRAY,IC,IND,LIST,LUVALUE,NUM
+2 DO ARRAY(1,.ARRAY)
+3 SET IC=0
+4 FOR
SET IC=$ORDER(ARRAY(IC))
IF 'IC
QUIT
Begin DoDot:1
+5 SET LUVALUE(1)=ARRAY(IC,1)
+6 DO FIND^DIC(811.8,"","","U",.LUVALUE,"","","","","LIST")
+7 IF '$DATA(LIST)
QUIT
+8 SET NUM=$PIECE(LIST("DILIST",0),U,1)
+9 IF NUM'=0
Begin DoDot:2
+10 FOR IND=1:1:NUM
Begin DoDot:3
+11 NEW DA,DIK
+12 SET DIK="^PXD(811.8,"
+13 SET DA=LIST("DILIST",2,IND)
+14 DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
+17 ;===============================================================
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
+2 ;entries to include.
+3 NEW ARRAY,FOUND,IEN,IC,LUVALUE
+4 DO ARRAY(1,.ARRAY)
+5 SET FOUND=0
+6 SET IC=0
+7 FOR
SET IC=+$ORDER(ARRAY(IC))
IF (IC=0)!(FOUND)
QUIT
Begin DoDot:1
+8 MERGE LUVALUE=ARRAY(IC)
+9 SET IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
+10 IF IEN=Y
SET FOUND=1
QUIT
End DoDot:1
+11 QUIT FOUND
+12 ;
PRE ;
+1 DO SSPC
+2 DO DELDD
+3 DO DELEI
+4 QUIT
POST ;
+1 DO RSPC
+2 ;D SMEXINS
+3 QUIT
+4 ;===============================================================
RSPC ;Restore the sponser classes to the new location.
+1 NEW ARRAY,CLASS,IEN,NAME,TEMP
+2 SET ARRAY("INFECTIOUS DISEASES PROGRAM OFFICE, VAHQ")="N"
+3 SET ARRAY("JOHN D DEMAKIS")="N"
+4 SET ARRAY("Mental Health and Behavioral Science Strategic Group")="N"
+5 SET ARRAY("Mental Health and Behavioral Science Strategic Group and Women Veterans Health Program")="N"
+6 SET ARRAY("National Clinical Practice Guideline Council")="N"
+7 SET ARRAY("Office of Geriatric Extended Care")="N"
+8 SET ARRAY("Office of Public Health and Environmental Hazards")="N"
+9 SET ARRAY("Office of Quality & Performance")="N"
+10 SET ARRAY("Women Veterans Health Program")="N"
+11 DO BMES^XPDUTL("Restoring Sponsor Classes")
+12 SET IEN=0
+13 FOR
SET IEN=+$ORDER(^XTMP("PXRMSPCS",IEN))
IF IEN=0
QUIT
Begin DoDot:1
+14 SET CLASS=^XTMP("PXRMSPCS",IEN)
+15 SET $PIECE(^PXRMD(811.6,IEN,100),U,1)=CLASS
End DoDot:1
+16 SET IEN=0
+17 FOR
SET IEN=$ORDER(^PXRMD(811.6,IEN))
IF IEN'>0
QUIT
Begin DoDot:1
+18 SET CLASS=$PIECE($GET(^PXRMD(811.6,IEN,100)),U)
+19 IF CLASS=""
Begin DoDot:2
+20 SET TEMP=$PIECE($GET(^PXRMD(811.6,IEN,0)),U,2)
+21 SET NAME=$PIECE($GET(^PXRMD(811.6,IEN,0)),U)
IF NAME=""
QUIT
+22 IF TEMP=""
SET TEMP=$SELECT($DATA(ARRAY(NAME))>0:ARRAY(NAME),1:"L")
+23 SET $PIECE(^PXRMD(811.6,IEN,100),U)=TEMP
SET CLASS=TEMP
End DoDot:2
+24 IF CLASS'=""
Begin DoDot:2
+25 SET TEMP=^PXRMD(811.6,IEN,0)
+26 SET ^PXRMD(811.6,IEN,0)=$PIECE(TEMP,U)
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;===============================================================
SMEXINS ;Silent mode install.
+1 NEW ARRAY,IC,IEN,LUVALUE,PXRMINST
+2 SET PXRMINST=1
+3 DO ARRAY(1,.ARRAY)
+4 SET IC=0
+5 FOR
SET IC=$ORDER(ARRAY(IC))
IF 'IC
QUIT
Begin DoDot:1
+6 MERGE LUVALUE=ARRAY(IC)
+7 SET IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
+8 IF IEN'=0
Begin DoDot:2
+9 NEW TEXT
+10 IF LUVALUE(1)["PARAMETER"
SET TEXT="Installing entry "_LUVALUE(1)
+11 IF '$TEST
SET TEXT="Installing reminder "_LUVALUE(1)
+12 DO BMES^XPDUTL(TEXT)
+13 DO INSTALL^PXRMEXSI(IEN,1)
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
+16 ;===============================================================
SSPC ;Save the Sponsor classes.
+1 NEW CDATE,CLASS,IEN,PDATE
+2 DO BMES^XPDUTL("Saving Sponsor Classes")
+3 SET CDATE=$$NOW^XLFDT
+4 SET PDATE=$$FMADD^XLFDT(CDATE,30)
+5 SET ^XTMP("PXRMSPCS",0)=PDATE_U_CDATE_U_"SPONSOR CLASSES"
+6 SET IEN=0
+7 FOR
SET IEN=+$ORDER(^PXRMD(811.6,IEN))
IF IEN=0
QUIT
Begin DoDot:1
+8 SET CLASS=$PIECE($GET(^PXRMD(811.6,IEN,0)),U,2)
+9 ;CHECK FOR TEST SITES
+10 IF $GET(CLASS)=""
SET CLASS=$PIECE($GET(^PXRMD(811.6,IEN,100)),U)
+11 SET ^XTMP("PXRMSPCS",IEN)=CLASS
End DoDot:1
+12 QUIT
