PXRMP4I ; SLC/PKR - PXRM*2.0*4 init routine. ;07/24/2006
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
Q
;
;==========================================
CFTINC(IEN) ;Return true if the computed finding should be included
;in the build.
N NAME
S NAME=$P(^PXRMD(811.4,IEN,0),U,1)
I NAME="VA-APPOINTMENTS FOR A PATIENT" Q 1
I NAME="VA-DATE OF BIRTH" Q 1
I NAME="VA-DATE OF DEATH" Q 1
I NAME="VA-HOSPITAL DISCHARGE DATE" Q 1
I NAME="VA-PATIENT TYPE" Q 1
I NAME="VA-PATIENTS WITH APPOINTMENTS" Q 1
I NAME="VA-PROGRESS NOTE" Q 1
I NAME="VA-PTF HOSPITAL DISCHARGE DATE" Q 1
I NAME="VA-REMINDER DEFINITION" Q 1
I NAME="VA-TREATING FACILITY LIST" Q 1
Q 0
;
;==========================================
DELDD ;Delete the old data dictionaries.
N DIU,TEXT
D EN^DDIOL("Removing old data dictionaries.")
S DIU(0)=""
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
. 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 EXARRAY^PXRMP4IW(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
;
;==========================================
DELLT ;Delete list templates
N IEN,IND,LIST,TEMP0
D LTL^PXRMP4IW(.LIST)
S IND=0
F S IND=$O(LIST(IND)) Q:IND="" D
. S IEN=$O(^SD(409.61,"B",LIST(IND),"")) Q:IEN=""
. S TEMP0=$G(^SD(409.61,IEN,0))
. K ^SD(409.61,IEN)
. S ^SD(409.61,IEN,0)=TEMP0
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 EXARRAY,FOUND,IEN,IC,LUVALUE
D EXARRAY^PXRMP4IW(1,.EXARRAY)
S FOUND=0
S IC=0
F S IC=+$O(EXARRAY(IC)) Q:(IC=0)!(FOUND) D
. M LUVALUE=EXARRAY(IC)
. S IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
. I IEN=Y S FOUND=1 Q
Q FOUND
;
;==========================================
OVLCHECK ;Check existing reminder definitions for baseline age range
;overlaps.
D BMES^XPDUTL("Checking reminder definitions for baseline age range overlap")
N DA,TEST
S DA=0
F S DA=+$O(^PXD(811.9,DA)) Q:DA=0 D
. S TEST=$$OVLAP^PXRMAGE
. I TEST W !,"Reminder ",$P(^PXD(811.9,DA,0),U,1),"; IEN= ",DA,!
Q
;
;==========================================
PRE ;
D SLLC
D DELDD
D DELEI
D DELLT
D RELTEMP^PXRMP4I1
D REOPTS^PXRMP4I1
D REPROTS^PXRMP4I1
N PXRMINST S PXRMINST=1
D RENAME^PXRMP4I1(811.4,"VA-DISCHARGE DATE","VA-LAST SERVICE SEPARATION DATE")
Q
;
;==========================================
POST ;
D FORMAT^PXRMDISC
D OVLCHECK
D RLLC
;D RTAXEXP
D RRSVC
D SPLT
D SAUTOP
D SLABENOD^PXRMP4I1
;D SMEXINS
;D POST^PXRMGECL
;D MHVWEB^PXRMP4IW
;D GECDIA^PXRMP4I1
;D SNEXTIP^PXRMP4I1
Q
;
;==========================================
RLLC ;Restore the Location List classes to the new location and delete
;the old location.
N CLASS,IEN,TEMP
D BMES^XPDUTL("Restoring Location List Classes")
S IEN=0
F S IEN=+$O(^XTMP("PXRMLLCS",IEN)) Q:IEN=0 D
. S CLASS=^XTMP("PXRMLLCS",IEN)
. S $P(^PXRMD(810.9,IEN,100),U,1)=CLASS
S IEN=0
F S IEN=+$O(^PXRMD(810.9,IEN)) Q:IEN=0 D
. S CLASS=$P(^PXRMD(810.9,IEN,100),U,1)
. I CLASS="" D
.. S TEMP=$P(^PXRMD(810.9,IEN,0),U,2)
.. I TEMP'="" S $P(^PXRMD(810.9,IEN,100),U,1)=TEMP
.. S CLASS=TEMP
. I CLASS'="" D
.. S TEMP=^PXRMD(810.9,IEN,0)
.. S ^PXRMD(810.9,IEN,0)=$P(TEMP,U,1)
Q
;
;==========================================
RRSVC ;Reformat reminder report template service categories.
N IEN,IND,SVCL
D BMES^XPDUTL("Reformatting reminder report service categories")
S IEN=0
F S IEN=+$O(^PXRMPT(810.1,IEN)) Q:IEN=0 D
. S SVCL="",IND=0
. F S IND=+$O(^PXRMPT(810.1,IEN,8,IND)) Q:IND=0 D
.. I SVCL="" S SVCL=^PXRMPT(810.1,IEN,8,IND,0)
.. E S SVCL=SVCL_","_^PXRMPT(810.1,IEN,8,IND,0)
. I SVCL="" Q
. K ^PXRMPT(810.1,IEN,8)
. S ^PXRMPT(810.1,IEN,8)=SVCL
Q
;
;==========================================
RSPC ;Restore the Sponsor classes to the new location.
N CLASS,IEN
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
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=$O(^PXD(811.2,"B","VA-WH BILATERAL MASTECTOMY",""))
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
;
;==========================================
SAUTOP ;Make sure the class field is "N" for national Extract Summary and
;Reminder Patient List entries. For these entries set the field
;AUTOMATICALLY PURGE to true. Set INCLUDE PCMM INSTITUTION to true
;for all VA-*IHD QUERI and VA-*MH QUERI lists.
D BMES^XPDUTL("Setting AUTOMATICALLY PURGE for national Extract Summaries and Patient Lists")
N IEN,NAME
S IEN=0 F S IEN=$O(^PXRMXT(810.3,IEN)) Q:IEN'>0 D
. S NAME=$P($G(^PXRMXT(810.3,IEN,0)),U)
. I NAME'["VA-",NAME'["LREPI" Q
. S $P(^PXRMXT(810.3,IEN,100),U)="N"
. S ^PXRMXT(810.3,IEN,50)=1
;
S IEN=0 F S IEN=$O(^PXRMXP(810.5,IEN)) Q:IEN'>0 D
. S NAME=$P($G(^PXRMXP(810.5,IEN,0)),U)
. I NAME["QUERI" S $P(^PXRMXP(810.5,IEN,0),U,10)=1
. I NAME'["VA-",NAME'["LREPI" Q
. S $P(^PXRMXP(810.5,IEN,100),U)="N"
. S ^PXRMXP(810.5,IEN,50)=1
Q
;
;==========================================
SLLC ;Save the Location List classes.
N CDATE,CLASS,IEN,PDATE
D BMES^XPDUTL("Saving Location List Classes")
S CDATE=$$NOW^XLFDT
S PDATE=$$FMADD^XLFDT(CDATE,30)
S ^XTMP("PXRMLLCS",0)=PDATE_U_CDATE_U_"LOCATION LIST CLASSES"
S IEN=0
F S IEN=+$O(^PXRMD(810.9,IEN)) Q:IEN=0 D
. S CLASS=$P(^PXRMD(810.9,IEN,0),U,2)
. I CLASS'="" S ^XTMP("PXRMLLCS",IEN)=CLASS
Q
;
;==========================================
SMEXINS ;Silent mode install.
N EXARRAY,IC,IEN,LUVALUE,PXRMINST,TEXT
S PXRMINST=1
D EXARRAY^PXRMP4IW(1,.EXARRAY)
S IC=0
F S IC=$O(EXARRAY(IC)) Q:'IC D
.M LUVALUE=EXARRAY(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
;
;==========================================
SPLT ;Set the Patient List Type field. In the original version the list
;was private only if the creator was stored. In the new version the
;TYPE field will be used to mark a list as public or private and
;the creator will be stored for all lists.
N CREATOR,IEN,TYPE
D BMES^XPDUTL("Setting Patient List TYPE field")
S IEN=0
F S IEN=+$O(^PXRMXP(810.5,IEN)) Q:IEN=0 D
. S CREATOR=$P(^PXRMXP(810.5,IEN,0),U,7)
. S TYPE=$S(CREATOR="":"PUB",1:"PVT")
. S $P(^PXRMXP(810.5,IEN,0),U,8)=TYPE
Q
;
;==========================================
SRSVC ;Save reminder report template service categories.
N CDATE,IEN,IND,PDATE,SVCL
D BMES^XPDUTL("Saving reminder report service categories")
S CDATE=$$NOW^XLFDT
S PDATE=$$FMADD^XLFDT(CDATE,30)
S ^XTMP("PXRMRSVC",0)=PDATE_U_CDATE_U_"SERVICE CATEGORIES"
S IEN=0
F S IEN=+$O(^PXRMPT(810.1,IEN)) Q:IEN=0 D
. S SVCL="",IND=0
. F S IND=+$O(^PXRMPT(810.1,IEN,8,IND)) Q:IND=0 D
.. I SVCL="" S SVCL=^PXRMPT(810.1,IEN,8,IND,0)
.. E S SVCL=SVCL_","_^PXRMPT(810.1,IEN,8,IND,0)
. I SVCL'="" S ^XTMP("PXRMRSVC",IEN)=SVCL
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(^PXRMD(811.6,IEN,0),U,2)
. S ^XTMP("PXRMSPCS",IEN)=CLASS
Q
;
PXRMP4I ; SLC/PKR - PXRM*2.0*4 init routine. ;07/24/2006
+1 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+2 QUIT
+3 ;
+4 ;==========================================
CFTINC(IEN) ;Return true if the computed finding should be included
+1 ;in the build.
+2 NEW NAME
+3 SET NAME=$PIECE(^PXRMD(811.4,IEN,0),U,1)
+4 IF NAME="VA-APPOINTMENTS FOR A PATIENT"
QUIT 1
+5 IF NAME="VA-DATE OF BIRTH"
QUIT 1
+6 IF NAME="VA-DATE OF DEATH"
QUIT 1
+7 IF NAME="VA-HOSPITAL DISCHARGE DATE"
QUIT 1
+8 IF NAME="VA-PATIENT TYPE"
QUIT 1
+9 IF NAME="VA-PATIENTS WITH APPOINTMENTS"
QUIT 1
+10 IF NAME="VA-PROGRESS NOTE"
QUIT 1
+11 IF NAME="VA-PTF HOSPITAL DISCHARGE DATE"
QUIT 1
+12 IF NAME="VA-REMINDER DEFINITION"
QUIT 1
+13 IF NAME="VA-TREATING FACILITY LIST"
QUIT 1
+14 QUIT 0
+15 ;
+16 ;==========================================
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.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
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 ;==========================================
DELEI ;If the Exchange File entry already exists delete it.
+1 NEW ARRAY,IC,IND,LIST,LUVALUE,NUM
+2 DO EXARRAY^PXRMP4IW(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 ;==========================================
DELLT ;Delete list templates
+1 NEW IEN,IND,LIST,TEMP0
+2 DO LTL^PXRMP4IW(.LIST)
+3 SET IND=0
+4 FOR
SET IND=$ORDER(LIST(IND))
IF IND=""
QUIT
Begin DoDot:1
+5 SET IEN=$ORDER(^SD(409.61,"B",LIST(IND),""))
IF IEN=""
QUIT
+6 SET TEMP0=$GET(^SD(409.61,IEN,0))
+7 KILL ^SD(409.61,IEN)
+8 SET ^SD(409.61,IEN,0)=TEMP0
End DoDot:1
+9 QUIT
+10 ;
+11 ;==========================================
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 EXARRAY,FOUND,IEN,IC,LUVALUE
+4 DO EXARRAY^PXRMP4IW(1,.EXARRAY)
+5 SET FOUND=0
+6 SET IC=0
+7 FOR
SET IC=+$ORDER(EXARRAY(IC))
IF (IC=0)!(FOUND)
QUIT
Begin DoDot:1
+8 MERGE LUVALUE=EXARRAY(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 ;
+13 ;==========================================
OVLCHECK ;Check existing reminder definitions for baseline age range
+1 ;overlaps.
+2 DO BMES^XPDUTL("Checking reminder definitions for baseline age range overlap")
+3 NEW DA,TEST
+4 SET DA=0
+5 FOR
SET DA=+$ORDER(^PXD(811.9,DA))
IF DA=0
QUIT
Begin DoDot:1
+6 SET TEST=$$OVLAP^PXRMAGE
+7 IF TEST
WRITE !,"Reminder ",$PIECE(^PXD(811.9,DA,0),U,1),"; IEN= ",DA,!
End DoDot:1
+8 QUIT
+9 ;
+10 ;==========================================
PRE ;
+1 DO SLLC
+2 DO DELDD
+3 DO DELEI
+4 DO DELLT
+5 DO RELTEMP^PXRMP4I1
+6 DO REOPTS^PXRMP4I1
+7 DO REPROTS^PXRMP4I1
+8 NEW PXRMINST
SET PXRMINST=1
+9 DO RENAME^PXRMP4I1(811.4,"VA-DISCHARGE DATE","VA-LAST SERVICE SEPARATION DATE")
+10 QUIT
+11 ;
+12 ;==========================================
POST ;
+1 DO FORMAT^PXRMDISC
+2 DO OVLCHECK
+3 DO RLLC
+4 ;D RTAXEXP
+5 DO RRSVC
+6 DO SPLT
+7 DO SAUTOP
+8 DO SLABENOD^PXRMP4I1
+9 ;D SMEXINS
+10 ;D POST^PXRMGECL
+11 ;D MHVWEB^PXRMP4IW
+12 ;D GECDIA^PXRMP4I1
+13 ;D SNEXTIP^PXRMP4I1
+14 QUIT
+15 ;
+16 ;==========================================
RLLC ;Restore the Location List classes to the new location and delete
+1 ;the old location.
+2 NEW CLASS,IEN,TEMP
+3 DO BMES^XPDUTL("Restoring Location List Classes")
+4 SET IEN=0
+5 FOR
SET IEN=+$ORDER(^XTMP("PXRMLLCS",IEN))
IF IEN=0
QUIT
Begin DoDot:1
+6 SET CLASS=^XTMP("PXRMLLCS",IEN)
+7 SET $PIECE(^PXRMD(810.9,IEN,100),U,1)=CLASS
End DoDot:1
+8 SET IEN=0
+9 FOR
SET IEN=+$ORDER(^PXRMD(810.9,IEN))
IF IEN=0
QUIT
Begin DoDot:1
+10 SET CLASS=$PIECE(^PXRMD(810.9,IEN,100),U,1)
+11 IF CLASS=""
Begin DoDot:2
+12 SET TEMP=$PIECE(^PXRMD(810.9,IEN,0),U,2)
+13 IF TEMP'=""
SET $PIECE(^PXRMD(810.9,IEN,100),U,1)=TEMP
+14 SET CLASS=TEMP
End DoDot:2
+15 IF CLASS'=""
Begin DoDot:2
+16 SET TEMP=^PXRMD(810.9,IEN,0)
+17 SET ^PXRMD(810.9,IEN,0)=$PIECE(TEMP,U,1)
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
+20 ;==========================================
RRSVC ;Reformat reminder report template service categories.
+1 NEW IEN,IND,SVCL
+2 DO BMES^XPDUTL("Reformatting reminder report service categories")
+3 SET IEN=0
+4 FOR
SET IEN=+$ORDER(^PXRMPT(810.1,IEN))
IF IEN=0
QUIT
Begin DoDot:1
+5 SET SVCL=""
SET IND=0
+6 FOR
SET IND=+$ORDER(^PXRMPT(810.1,IEN,8,IND))
IF IND=0
QUIT
Begin DoDot:2
+7 IF SVCL=""
SET SVCL=^PXRMPT(810.1,IEN,8,IND,0)
+8 IF '$TEST
SET SVCL=SVCL_","_^PXRMPT(810.1,IEN,8,IND,0)
End DoDot:2
+9 IF SVCL=""
QUIT
+10 KILL ^PXRMPT(810.1,IEN,8)
+11 SET ^PXRMPT(810.1,IEN,8)=SVCL
End DoDot:1
+12 QUIT
+13 ;
+14 ;==========================================
RSPC ;Restore the Sponsor classes to the new location.
+1 NEW CLASS,IEN
+2 DO BMES^XPDUTL("Restoring Sponsor Classes")
+3 SET IEN=0
+4 FOR
SET IEN=+$ORDER(^XTMP("PXRMSPCS",IEN))
IF IEN=0
QUIT
Begin DoDot:1
+5 SET CLASS=^XTMP("PXRMSPCS",IEN)
+6 SET $PIECE(^PXRMD(811.6,IEN,100),U,1)=CLASS
End DoDot:1
+7 QUIT
+8 ;
+9 ;==========================================
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=$ORDER(^PXD(811.2,"B","VA-WH BILATERAL MASTECTOMY",""))
+5 SET TEXT=" Working on taxonomy "_IEN
+6 DO BMES^XPDUTL(TEXT)
+7 DO DELEXTL^PXRMBXTL(IEN)
+8 DO EXPAND^PXRMBXTL(IEN,"")
+9 FOR FILENUM=80,80.1,81
Begin DoDot:1
+10 SET IND=0
+11 FOR
SET IND=+$ORDER(^PXD(811.2,IEN,FILENUM,IND))
IF IND=0
QUIT
Begin DoDot:2
+12 SET TEMP=^PXD(811.2,IEN,FILENUM,IND,0)
+13 SET LOW=$PIECE(TEMP,U,1)
SET HIGH=$PIECE(TEMP,U,2)
+14 SET ALOW=$SELECT(FILENUM=80:$$PREV^ICDAPIU(LOW),FILENUM=80.1:$$PREV^ICDAPIU(LOW),FILENUM=81:$$PREV^ICPTAPIU(LOW))
+15 SET AHIGH=$SELECT(FILENUM=80:$$NEXT^ICDAPIU(HIGH),FILENUM=80.1:$$NEXT^ICDAPIU(HIGH),FILENUM=81:$$NEXT^ICPTAPIU(HIGH))
+16 SET $PIECE(^PXD(811.2,IEN,FILENUM,IND,0),U,3,4)=ALOW_U_AHIGH
End DoDot:2
End DoDot:1
+17 DO BMES^XPDUTL(" DONE")
+18 QUIT
+19 ;
+20 ;==========================================
SAUTOP ;Make sure the class field is "N" for national Extract Summary and
+1 ;Reminder Patient List entries. For these entries set the field
+2 ;AUTOMATICALLY PURGE to true. Set INCLUDE PCMM INSTITUTION to true
+3 ;for all VA-*IHD QUERI and VA-*MH QUERI lists.
+4 DO BMES^XPDUTL("Setting AUTOMATICALLY PURGE for national Extract Summaries and Patient Lists")
+5 NEW IEN,NAME
+6 SET IEN=0
FOR
SET IEN=$ORDER(^PXRMXT(810.3,IEN))
IF IEN'>0
QUIT
Begin DoDot:1
+7 SET NAME=$PIECE($GET(^PXRMXT(810.3,IEN,0)),U)
+8 IF NAME'["VA-"
IF NAME'["LREPI"
QUIT
+9 SET $PIECE(^PXRMXT(810.3,IEN,100),U)="N"
+10 SET ^PXRMXT(810.3,IEN,50)=1
End DoDot:1
+11 ;
+12 SET IEN=0
FOR
SET IEN=$ORDER(^PXRMXP(810.5,IEN))
IF IEN'>0
QUIT
Begin DoDot:1
+13 SET NAME=$PIECE($GET(^PXRMXP(810.5,IEN,0)),U)
+14 IF NAME["QUERI"
SET $PIECE(^PXRMXP(810.5,IEN,0),U,10)=1
+15 IF NAME'["VA-"
IF NAME'["LREPI"
QUIT
+16 SET $PIECE(^PXRMXP(810.5,IEN,100),U)="N"
+17 SET ^PXRMXP(810.5,IEN,50)=1
End DoDot:1
+18 QUIT
+19 ;
+20 ;==========================================
SLLC ;Save the Location List classes.
+1 NEW CDATE,CLASS,IEN,PDATE
+2 DO BMES^XPDUTL("Saving Location List Classes")
+3 SET CDATE=$$NOW^XLFDT
+4 SET PDATE=$$FMADD^XLFDT(CDATE,30)
+5 SET ^XTMP("PXRMLLCS",0)=PDATE_U_CDATE_U_"LOCATION LIST CLASSES"
+6 SET IEN=0
+7 FOR
SET IEN=+$ORDER(^PXRMD(810.9,IEN))
IF IEN=0
QUIT
Begin DoDot:1
+8 SET CLASS=$PIECE(^PXRMD(810.9,IEN,0),U,2)
+9 IF CLASS'=""
SET ^XTMP("PXRMLLCS",IEN)=CLASS
End DoDot:1
+10 QUIT
+11 ;
+12 ;==========================================
SMEXINS ;Silent mode install.
+1 NEW EXARRAY,IC,IEN,LUVALUE,PXRMINST,TEXT
+2 SET PXRMINST=1
+3 DO EXARRAY^PXRMP4IW(1,.EXARRAY)
+4 SET IC=0
+5 FOR
SET IC=$ORDER(EXARRAY(IC))
IF 'IC
QUIT
Begin DoDot:1
+6 MERGE LUVALUE=EXARRAY(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 ;==========================================
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
+2 ;TYPE field will be used to mark a list as public or private and
+3 ;the creator will be stored for all lists.
+4 NEW CREATOR,IEN,TYPE
+5 DO BMES^XPDUTL("Setting Patient List TYPE field")
+6 SET IEN=0
+7 FOR
SET IEN=+$ORDER(^PXRMXP(810.5,IEN))
IF IEN=0
QUIT
Begin DoDot:1
+8 SET CREATOR=$PIECE(^PXRMXP(810.5,IEN,0),U,7)
+9 SET TYPE=$SELECT(CREATOR="":"PUB",1:"PVT")
+10 SET $PIECE(^PXRMXP(810.5,IEN,0),U,8)=TYPE
End DoDot:1
+11 QUIT
+12 ;
+13 ;==========================================
SRSVC ;Save reminder report template service categories.
+1 NEW CDATE,IEN,IND,PDATE,SVCL
+2 DO BMES^XPDUTL("Saving reminder report service categories")
+3 SET CDATE=$$NOW^XLFDT
+4 SET PDATE=$$FMADD^XLFDT(CDATE,30)
+5 SET ^XTMP("PXRMRSVC",0)=PDATE_U_CDATE_U_"SERVICE CATEGORIES"
+6 SET IEN=0
+7 FOR
SET IEN=+$ORDER(^PXRMPT(810.1,IEN))
IF IEN=0
QUIT
Begin DoDot:1
+8 SET SVCL=""
SET IND=0
+9 FOR
SET IND=+$ORDER(^PXRMPT(810.1,IEN,8,IND))
IF IND=0
QUIT
Begin DoDot:2
+10 IF SVCL=""
SET SVCL=^PXRMPT(810.1,IEN,8,IND,0)
+11 IF '$TEST
SET SVCL=SVCL_","_^PXRMPT(810.1,IEN,8,IND,0)
End DoDot:2
+12 IF SVCL'=""
SET ^XTMP("PXRMRSVC",IEN)=SVCL
End DoDot:1
+13 QUIT
+14 ;
+15 ;==========================================
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(^PXRMD(811.6,IEN,0),U,2)
+9 SET ^XTMP("PXRMSPCS",IEN)=CLASS
End DoDot:1
+10 QUIT
+11 ;
