PXRMP10I ; SLC/PKR - PXRM*2.0*10 init routine. ;09/28/2007
;;2.0;CLINICAL REMINDERS;**10**;Feb 04, 2005;Build 25
Q
;
DELEI ;If the Exchange File entry already exists delete it.
N ARRAY,IC,IND,LIST,LUVALUE,NUM
D EXARRAY("L",.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
;==========================================
DITEMAR(DIEN,ARRAY) ;
;DIEN is the IEN of the dialog top level
;Array contains the dialog elements and groups within the dialog.
N CNT,IEN,REPIEN,TYPE
S CNT=0 F S CNT=$O(^PXRMD(801.41,DIEN,10,CNT)) Q:CNT'>0 D
.S IEN=$P($G(^PXRMD(801.41,DIEN,10,CNT,0)),U,2) Q:IEN'>0
.S REPIEN=$P($G(^PXRMD(801.41,IEN,49)),U,3)
.I REPIEN>0 D DITEMAR(REPIEN,.ARRAY)
.S TYPE=$P($G(^PXRMD(801.41,IEN,0)),U,4)
.I TYPE="G"!(TYPE="E") D DITEMAR(IEN,.ARRAY)
.I '$D(ARRAY(IEN)) S ARRAY(IEN)=""
I '$D(ARRAY(DIEN)) S ARRAY(DIEN)=""
Q
;
DMAKENAT(DA) ;
N CLASS,DIE,DR,IEN,NAME,NEWNAME,PREFIX,TYPE
S NAME=$P($G(^PXRMD(801.41,DA,0)),U)
I $E(NAME,1,3)="VA-"!($E(NAME,1,4)="PXRM") Q
S CLASS="N"
S DIE="^PXRMXD(801.41,"
S DR="100////^S X=CLASS"
D ^DIE
S TYPE=$P($G(^PXRMD(801.41,DA,0)),U,4)
S PREFIX=$S(TYPE="R":"VA-",TYPE="G":"VA-",TYPE="E":"VA-",1:"PXRM ")
S NEWNAME=PREFIX_NAME
D RENAME(801.41,NAME,NEWNAME)
Q
;
EXARRAY(MODE,ARRAY) ;List of exchange entries used by delete and install
N CNT
S CNT=0
;
S CNT=CNT+1,ARRAY(CNT,1)="VA-VANOD SKIN ASSESSMENT"
I MODE["I" S ARRAY(CNT,2)="07/16/2007@14:45:37"
I MODE["A" S ARRAY(CNT,3)="O"
;
S CNT=CNT+1,ARRAY(CNT,1)="VA-VANOD SKIN REASSESSMENT"
I MODE["I" S ARRAY(CNT,2)="07/16/2007@14:46:02"
I MODE["A" S ARRAY(CNT,3)="O"
;
S CNT=CNT+1,ARRAY(CNT,1)="GMTS SKIN RISK HS TYPES"
I MODE["I" S ARRAY(CNT,2)="07/09/2007@13:20:09"
I MODE["A" S ARRAY(CNT,3)="O"
;
S CNT=CNT+1,ARRAY(CNT,1)="GMTS SKIN RISK HS OBJECTS"
I MODE["I" S ARRAY(CNT,2)="07/09/2007@13:21:13"
I MODE["A" S ARRAY(CNT,3)="O"
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("I",.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
;
NATCONV ;
N ARRAY,CLASS,CNT,DA,DIE,DIEN,DR,IEN,NAME,PXRMEXCH,PXRMINST,RIEN
S PXRMEXCH=1,PXRMINST=1,CLASS="N"
F NAME="VANOD SKIN ASSESSMENT","VANOD SKIN REASSESSMENT" D
.S RIEN=$O(^PXD(811.9,"B",NAME,"")) Q:RIEN'>0
.S DA=RIEN,DIE="^PXD(811.9,",DR="100///^S X=CLASS"
.D ^DIE
.D RENAME(811.9,NAME,"VA-"_NAME)
.S DIEN=$P($G(^PXD(811.9,RIEN,51)),U) Q:DIEN'>0
.D DITEMAR(DIEN,.ARRAY)
.S IEN=0 F S IEN=$O(ARRAY(IEN)) Q:IEN'>0 D
..D DMAKENAT(IEN)
.D DMAKENAT(DIEN)
Q
;
PRE ;
D DELEI
D NATCONV
Q
;
POST ;
D SMEXINS
Q
;
RENAME(FILENUM,OLDNAME,NEWNAME) ;Rename entry OLDNAME to NEWNAME in
;file number FILENUM.
N DA,DIE,DR,NIEN
S NIEN=$$FIND1^DIC(FILENUM,"","BX",NEWNAME) I NIEN>0 Q
S DA=$$FIND1^DIC(FILENUM,"","BX",OLDNAME)
I DA=0 Q
S DIE=FILENUM
S DR=".01///^S X=NEWNAME"
D ^DIE
Q
;
SENDDLG(IEN) ;
N NAME
S NAME=$P($G(^PXRMD(801.41,IEN,0)),U)
I NAME="PXRM BRADEN 6-8" Q 1
I NAME="PXRM BRADEN 10-12" Q 1
I NAME="PXRM BRADEN 13-14" Q 1
I NAME="PXRM BRADEN 15-18" Q 1
I NAME="PXRM BRADEN 19-23" Q 1
I NAME="PXRM VANOD PU LOCATIONS" Q 1
I NAME="PXRM VANOD SKIN COLOR" Q 1
I NAME="PXRM VANOD SKIN MOISTURE" Q 1
I NAME="PXRM VANOD SKIN TEMP" Q 1
I NAME="PXRM VANOD SKIN TURGOR" Q 1
I NAME="PXRM VANOD DATE FORCED TODAY" Q 1
Q 0
;
SMEXINS ;Silent mode install
N ACTION,EXARRAY,IC,IEN,LUVALUE,PXRMINST,TEXT
S PXRMINST=1
D EXARRAY("IA",.EXARRAY)
S IC=0
F S IC=$O(EXARRAY(IC)) Q:'IC D
.I EXARRAY(IC,1)["GMTS" Q
.S LUVALUE(1)=EXARRAY(IC,1),LUVALUE(IC,2)=EXARRAY(IC,2)
.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)
.. I $$PATCH^XPDUTL("PXRM*2.0*6") D
... S ACTION=EXARRAY(IC,3)
... D INSTALL^PXRMEXSI(IEN,ACTION,1)
.. I '$$PATCH^XPDUTL("PXRM*2.0*6") D INSTALL^PXRMEXSI(IEN,1)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMP10I 4597 printed Apr 09, 2024@20:51:35 Page 2
PXRMP10I ; SLC/PKR - PXRM*2.0*10 init routine. ;09/28/2007
+1 ;;2.0;CLINICAL REMINDERS;**10**;Feb 04, 2005;Build 25
+2 QUIT
+3 ;
DELEI ;If the Exchange File entry already exists delete it.
+1 NEW ARRAY,IC,IND,LIST,LUVALUE,NUM
+2 DO EXARRAY("L",.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 ;==========================================
DITEMAR(DIEN,ARRAY) ;
+1 ;DIEN is the IEN of the dialog top level
+2 ;Array contains the dialog elements and groups within the dialog.
+3 NEW CNT,IEN,REPIEN,TYPE
+4 SET CNT=0
FOR
SET CNT=$ORDER(^PXRMD(801.41,DIEN,10,CNT))
if CNT'>0
QUIT
Begin DoDot:1
+5 SET IEN=$PIECE($GET(^PXRMD(801.41,DIEN,10,CNT,0)),U,2)
if IEN'>0
QUIT
+6 SET REPIEN=$PIECE($GET(^PXRMD(801.41,IEN,49)),U,3)
+7 IF REPIEN>0
DO DITEMAR(REPIEN,.ARRAY)
+8 SET TYPE=$PIECE($GET(^PXRMD(801.41,IEN,0)),U,4)
+9 IF TYPE="G"!(TYPE="E")
DO DITEMAR(IEN,.ARRAY)
+10 IF '$DATA(ARRAY(IEN))
SET ARRAY(IEN)=""
End DoDot:1
+11 IF '$DATA(ARRAY(DIEN))
SET ARRAY(DIEN)=""
+12 QUIT
+13 ;
DMAKENAT(DA) ;
+1 NEW CLASS,DIE,DR,IEN,NAME,NEWNAME,PREFIX,TYPE
+2 SET NAME=$PIECE($GET(^PXRMD(801.41,DA,0)),U)
+3 IF $EXTRACT(NAME,1,3)="VA-"!($EXTRACT(NAME,1,4)="PXRM")
QUIT
+4 SET CLASS="N"
+5 SET DIE="^PXRMXD(801.41,"
+6 SET DR="100////^S X=CLASS"
+7 DO ^DIE
+8 SET TYPE=$PIECE($GET(^PXRMD(801.41,DA,0)),U,4)
+9 SET PREFIX=$SELECT(TYPE="R":"VA-",TYPE="G":"VA-",TYPE="E":"VA-",1:"PXRM ")
+10 SET NEWNAME=PREFIX_NAME
+11 DO RENAME(801.41,NAME,NEWNAME)
+12 QUIT
+13 ;
EXARRAY(MODE,ARRAY) ;List of exchange entries used by delete and install
+1 NEW CNT
+2 SET CNT=0
+3 ;
+4 SET CNT=CNT+1
SET ARRAY(CNT,1)="VA-VANOD SKIN ASSESSMENT"
+5 IF MODE["I"
SET ARRAY(CNT,2)="07/16/2007@14:45:37"
+6 IF MODE["A"
SET ARRAY(CNT,3)="O"
+7 ;
+8 SET CNT=CNT+1
SET ARRAY(CNT,1)="VA-VANOD SKIN REASSESSMENT"
+9 IF MODE["I"
SET ARRAY(CNT,2)="07/16/2007@14:46:02"
+10 IF MODE["A"
SET ARRAY(CNT,3)="O"
+11 ;
+12 SET CNT=CNT+1
SET ARRAY(CNT,1)="GMTS SKIN RISK HS TYPES"
+13 IF MODE["I"
SET ARRAY(CNT,2)="07/09/2007@13:20:09"
+14 IF MODE["A"
SET ARRAY(CNT,3)="O"
+15 ;
+16 SET CNT=CNT+1
SET ARRAY(CNT,1)="GMTS SKIN RISK HS OBJECTS"
+17 IF MODE["I"
SET ARRAY(CNT,2)="07/09/2007@13:21:13"
+18 IF MODE["A"
SET ARRAY(CNT,3)="O"
+19 QUIT
+20 ;
+21 ;==========================================
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("I",.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 ;
NATCONV ;
+1 NEW ARRAY,CLASS,CNT,DA,DIE,DIEN,DR,IEN,NAME,PXRMEXCH,PXRMINST,RIEN
+2 SET PXRMEXCH=1
SET PXRMINST=1
SET CLASS="N"
+3 FOR NAME="VANOD SKIN ASSESSMENT","VANOD SKIN REASSESSMENT"
Begin DoDot:1
+4 SET RIEN=$ORDER(^PXD(811.9,"B",NAME,""))
if RIEN'>0
QUIT
+5 SET DA=RIEN
SET DIE="^PXD(811.9,"
SET DR="100///^S X=CLASS"
+6 DO ^DIE
+7 DO RENAME(811.9,NAME,"VA-"_NAME)
+8 SET DIEN=$PIECE($GET(^PXD(811.9,RIEN,51)),U)
if DIEN'>0
QUIT
+9 DO DITEMAR(DIEN,.ARRAY)
+10 SET IEN=0
FOR
SET IEN=$ORDER(ARRAY(IEN))
if IEN'>0
QUIT
Begin DoDot:2
+11 DO DMAKENAT(IEN)
End DoDot:2
+12 DO DMAKENAT(DIEN)
End DoDot:1
+13 QUIT
+14 ;
PRE ;
+1 DO DELEI
+2 DO NATCONV
+3 QUIT
+4 ;
POST ;
+1 DO SMEXINS
+2 QUIT
+3 ;
RENAME(FILENUM,OLDNAME,NEWNAME) ;Rename entry OLDNAME to NEWNAME in
+1 ;file number FILENUM.
+2 NEW DA,DIE,DR,NIEN
+3 SET NIEN=$$FIND1^DIC(FILENUM,"","BX",NEWNAME)
IF NIEN>0
QUIT
+4 SET DA=$$FIND1^DIC(FILENUM,"","BX",OLDNAME)
+5 IF DA=0
QUIT
+6 SET DIE=FILENUM
+7 SET DR=".01///^S X=NEWNAME"
+8 DO ^DIE
+9 QUIT
+10 ;
SENDDLG(IEN) ;
+1 NEW NAME
+2 SET NAME=$PIECE($GET(^PXRMD(801.41,IEN,0)),U)
+3 IF NAME="PXRM BRADEN 6-8"
QUIT 1
+4 IF NAME="PXRM BRADEN 10-12"
QUIT 1
+5 IF NAME="PXRM BRADEN 13-14"
QUIT 1
+6 IF NAME="PXRM BRADEN 15-18"
QUIT 1
+7 IF NAME="PXRM BRADEN 19-23"
QUIT 1
+8 IF NAME="PXRM VANOD PU LOCATIONS"
QUIT 1
+9 IF NAME="PXRM VANOD SKIN COLOR"
QUIT 1
+10 IF NAME="PXRM VANOD SKIN MOISTURE"
QUIT 1
+11 IF NAME="PXRM VANOD SKIN TEMP"
QUIT 1
+12 IF NAME="PXRM VANOD SKIN TURGOR"
QUIT 1
+13 IF NAME="PXRM VANOD DATE FORCED TODAY"
QUIT 1
+14 QUIT 0
+15 ;
SMEXINS ;Silent mode install
+1 NEW ACTION,EXARRAY,IC,IEN,LUVALUE,PXRMINST,TEXT
+2 SET PXRMINST=1
+3 DO EXARRAY("IA",.EXARRAY)
+4 SET IC=0
+5 FOR
SET IC=$ORDER(EXARRAY(IC))
if 'IC
QUIT
Begin DoDot:1
+6 IF EXARRAY(IC,1)["GMTS"
QUIT
+7 SET LUVALUE(1)=EXARRAY(IC,1)
SET LUVALUE(IC,2)=EXARRAY(IC,2)
+8 SET IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
+9 IF IEN'=0
Begin DoDot:2
+10 NEW TEXT
+11 IF LUVALUE(1)["PARAMETER"
SET TEXT="Installing entry "_LUVALUE(1)
+12 IF '$TEST
SET TEXT="Installing reminder "_LUVALUE(1)
+13 DO BMES^XPDUTL(TEXT)
+14 IF $$PATCH^XPDUTL("PXRM*2.0*6")
Begin DoDot:3
+15 SET ACTION=EXARRAY(IC,3)
+16 DO INSTALL^PXRMEXSI(IEN,ACTION,1)
End DoDot:3
+17 IF '$$PATCH^XPDUTL("PXRM*2.0*6")
DO INSTALL^PXRMEXSI(IEN,1)
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
