DVBA278P ;ALB/GTS - PATCH DVBA*2.7*8 TO CLEANUP 396.1 DD ; 4/29/96
;;2.7;AMIE;**8**;Apr 10, 1995
;
TEXT ; write lines for user
;; This routine will loop through all fields in the AMIE SITE PARAMETER
;; file looking for fields not supported with class I software. When
;; such a field is found, the installer will be asked if they want to
;; delete the field. When all fields are checked, a message will be
;; sent to the installer indicating what they selected to delete.
;; This message serves as record of what was selected for a particular
;; install and can be used to check if existing class III fields are
;; needed. The user may abort the install by entering an '^' at
;; the Device selection prompt. If you are unsure that the fields
;; you have selected for deletion are not used by any class III
;; programming at your site, PLEASE '^' AT THE DEVICE SELECTION
;; PROMPT AND REVIEW THE MAIL MESSAGE THAT IS DELIVERED. You may
;; rerun the install at any time after you have reviewed the mail
;; message.
;;
;;QUIT
;
ENVCHKQ QUIT ;** Quit the environment check. Only called so routine is
; ** available from Pre-Init questions.
;
QUEST ;** Entry point - Question Class III fields
N TXTVAR
D KVARS
D MES^XPDUTL(" "),MES^XPDUTL(" ")
F I=1:1 S TXTVAR=$P($T(TEXT+I),";;",2) Q:TXTVAR="QUIT" DO
.S:TXTVAR="" TXTVAR=" "
.D MES^XPDUTL(TXTVAR)
D START
Q
;
;
START ;** Start processing
S (I,NODE,COUNT,QUESDA)=0
;
;** Look for unsupported fields
D MES^XPDUTL(" ")
D MES^XPDUTL("Inspecting file 396.1 for unsupported fields.")
;
;** Class I fld array
F FILE=396.1,396.12,396.13,396.14,396.115 DO
.F I=(I+1):1 S FIELDVAR=$P($T(FIELDS+I),";;",2) Q:(FIELDVAR="QUIT") DO
..S CLASSI(FILE,FIELDVAR)=""
;
;** Fields at site
F FILE=396.1,396.12,396.13,396.14,396.115 DO
.F FLDDA=0:0 S FLDDA=$O(^DD(FILE,FLDDA)) Q:'FLDDA DO
..I $D(^DD(FILE,FLDDA,0)),'$D(CLASSI(FILE,FLDDA)) DO
...S CLASSIII(FILE,FLDDA)=$P(^DD(FILE,FLDDA,0),"^",1)_"^"_$P(^(0),"^",4)
;
;** If no Class III fields
I '$D(CLASSIII) DO
.D MES^XPDUTL(" ")
.D MES^XPDUTL(".....no unsupported fields were found!")
;
;** Nullify all XPDQUES nodes
S QUESSUB=""
F S QUESSUB=$O(XPDQUES(QUESSUB)) Q:(QUESSUB']"") DO
.S XPDQUES(QUESSUB)=""
.S XPDQUES(QUESSUB,"A")=""
;
;** Set up XPDQUES nodes
S FILE=""
F S FILE=$O(CLASSIII(FILE)) Q:('FILE!($D(DVBAOUT))) DO
.S FLDDA=""
.F S FLDDA=$O(CLASSIII(FILE,FLDDA)) Q:('FLDDA!($D(DVBAOUT))) DO
..W !!!,?1,"Field #",?12,"Field Name",?45,"Node;Piece"
..W !,?3,FLDDA
..W ?12,$P(CLASSIII(FILE,FLDDA),U,1)
..W ?48,$P(CLASSIII(FILE,FLDDA),U,2)
..S DIR(0)="YAO^",DIR("A")="Do you want to delete this field? "
..S DIR("B")="YES" D ^DIR
..I $D(DTOUT)!($D(DUOUT)!($D(DIROUT))) S DVBAOUT=""
..I '$D(DVBAOUT)&(+Y=1) DO
...S QUESDA=QUESDA+1
...S QUESSUB="PRE"_QUESDA
...S XPDQUES(QUESSUB)=$P(CLASSIII(FILE,FLDDA),U,1)_"^"_FLDDA_"^"_FILE
...S XPDQUES(QUESSUB,"A")=$P(CLASSIII(FILE,FLDDA),U,1)_" selected for deletion!"
..K DIR,X,Y
I $D(DVBAOUT) K XPDQUES
I '$D(DVBAOUT) D MAIL
KVARS K COUNT,DFN,I,NODE,NODENM,FIELDVAR,FLDDA,FILE,QUESDA
K CLASSI,CLASSIII,DVBAOUT
K DTOUT,DUOUT,DIROUT
Q
;
MAIL ; mail message of bogus nodes found
N DIFROM
S XMY(DUZ)="",XMDUZ=.5
S XMSUB="AMIE SITE PARAMETER file field cleanup"
S XMTEXT="^TMP(""DVBA V2.7 P8 E-MAIL"","_$J_","
S I=0,COUNT=0
S TEXT="This Mailman message records the Class III fields selected for deletion"
D LINE(TEXT)
S TEXT=" with patch DVBA*2.7*8. These fields are only deleted if/when the"
D LINE(TEXT)
S TEXT=" installation was/is completed."
D LINE(TEXT)
D LINE(" ")
S TEXT=" The following fields were selected to delete from the AMIE SITE"
D LINE(TEXT)
S TEXT=" PARAMETER file (#396.1) (Multiples included):"
D LINE(TEXT)
D LINE(" ")
I '$D(XPDQUES) DO
.S TEXT=" No fields selected for deletion!"
.D LINE(TEXT)
I $D(XPDQUES("PRE1")),(XPDQUES("PRE1")="") DO
.S TEXT=" No fields selected for deletion!"
.D LINE(TEXT)
I $D(XPDQUES("PRE1")),(XPDQUES("PRE1")'="") DO
.S TEXT=" FIELD NAME FIELD # FILE #"
.D LINE(TEXT)
.S TEXT=" ========== ======= ======"
.D LINE(TEXT)
.S I="PRE0"
.F S I=$O(XPDQUES(I)) Q:(I']"") D
..S (BLANK1,BLANK2)=""
..S $P(BLANK1," ",(37-$L($P(XPDQUES(I),"^",1))))=""
..S TEXT=" "_$P(XPDQUES(I),"^",1)_BLANK1_$P(XPDQUES(I),"^",2)
..S $P(BLANK2," ",(53-$L(TEXT)))=""
..S TEXT=TEXT_BLANK2_$P(XPDQUES(I),"^",3)
..D LINE(TEXT)
D ^XMD
K XMDUZ,XMY,XMTEXT,XMSUB,BLANK1,BLANK2,TEXT,QUESSUB
K ^TMP("DVBA V2.7 P8 E-MAIL",$J)
Q
;
;
LINE(TEXT) ; add line to array for e-mail
S COUNT=COUNT+1,^TMP("DVBA V2.7 P8 E-MAIL",$J,COUNT)=TEXT
Q
;
FLDCLEAN ;**Delete selected fields
I $D(XPDQUES) DO
.N I,SITEDA,MULTDA,FLDDA,FILEDA1,NODE,CLEANFLD
.S SITEDA=0
.S SITEDA=$O(^DVB(396.1,SITEDA))
.S I="PRE0"
.F S I=$O(XPDQUES(I)) Q:(I']"") Q:(XPDQUES(I)="") D
..S FILEDA1=$P(XPDQUES(I),"^",3)
..S FLDDA=$P(XPDQUES(I),"^",2)
..;
..;** Remove data in fields deleted
..I FILEDA1=396.1 DO
...S DIE="^DVB(396.1,",DA=SITEDA
...S DR=FLDDA_"////@"
...D ^DIE
...K DIE,DA,DR
..I FILEDA1'=396.1 DO
...S (CLEANFLD,MULTDA)=0
...S MULTDA=$O(^DD(396.1,"SB",FILEDA1,0))
...S:MULTDA CLEANFLD=1,NODE=$P($P(^DD(396.1,MULTDA,0),"^",4),";",1)
...I CLEANFLD DO
....S MULTDA=0
....F S MULTDA=$O(^DVB(396.1,SITEDA,NODE,MULTDA)) Q:'MULTDA DO
.....S DIE="^DVB(396.1,"_SITEDA_","_NODE_","
.....S DA=MULTDA,DA(1)=SITEDA
.....S DR=FLDDA_"////@"
.....D ^DIE
.....K DIE,DA,DR
..;
..;** Remove from DD
..S DA=FLDDA
..S DA(1)=FILEDA1
..S DIK="^DD("_DA(1)_","
..D ^DIK
..K DA,DIK
Q
;
FIELDS ; list of fields in 396.1
;;.01
;;.11
;;2
;;3
;;4
;;6
;;7
;;8
;;9
;;10
;;11
;;12
;;14
;;15
;;16
;;17
;;18
;;50
;;90
;;QUIT
P12 ;;.01
;;QUIT
P13 ;;.01
;;1
;;QUIT
P14 ;;.01
;;1
;;QUIT
P115 ;;.01
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBA278P 6072 printed Apr 09, 2024@20:50:45 Page 2
DVBA278P ;ALB/GTS - PATCH DVBA*2.7*8 TO CLEANUP 396.1 DD ; 4/29/96
+1 ;;2.7;AMIE;**8**;Apr 10, 1995
+2 ;
TEXT ; write lines for user
+1 ;; This routine will loop through all fields in the AMIE SITE PARAMETER
+2 ;; file looking for fields not supported with class I software. When
+3 ;; such a field is found, the installer will be asked if they want to
+4 ;; delete the field. When all fields are checked, a message will be
+5 ;; sent to the installer indicating what they selected to delete.
+6 ;; This message serves as record of what was selected for a particular
+7 ;; install and can be used to check if existing class III fields are
+8 ;; needed. The user may abort the install by entering an '^' at
+9 ;; the Device selection prompt. If you are unsure that the fields
+10 ;; you have selected for deletion are not used by any class III
+11 ;; programming at your site, PLEASE '^' AT THE DEVICE SELECTION
+12 ;; PROMPT AND REVIEW THE MAIL MESSAGE THAT IS DELIVERED. You may
+13 ;; rerun the install at any time after you have reviewed the mail
+14 ;; message.
+15 ;;
+16 ;;QUIT
+17 ;
ENVCHKQ ;** Quit the environment check. Only called so routine is
QUIT
+1 ; ** available from Pre-Init questions.
+2 ;
QUEST ;** Entry point - Question Class III fields
+1 NEW TXTVAR
+2 DO KVARS
+3 DO MES^XPDUTL(" ")
DO MES^XPDUTL(" ")
+4 FOR I=1:1
SET TXTVAR=$PIECE($TEXT(TEXT+I),";;",2)
if TXTVAR="QUIT"
QUIT
Begin DoDot:1
+5 if TXTVAR=""
SET TXTVAR=" "
+6 DO MES^XPDUTL(TXTVAR)
End DoDot:1
+7 DO START
+8 QUIT
+9 ;
+10 ;
START ;** Start processing
+1 SET (I,NODE,COUNT,QUESDA)=0
+2 ;
+3 ;** Look for unsupported fields
+4 DO MES^XPDUTL(" ")
+5 DO MES^XPDUTL("Inspecting file 396.1 for unsupported fields.")
+6 ;
+7 ;** Class I fld array
+8 FOR FILE=396.1,396.12,396.13,396.14,396.115
Begin DoDot:1
+9 FOR I=(I+1):1
SET FIELDVAR=$PIECE($TEXT(FIELDS+I),";;",2)
if (FIELDVAR="QUIT")
QUIT
Begin DoDot:2
+10 SET CLASSI(FILE,FIELDVAR)=""
End DoDot:2
End DoDot:1
+11 ;
+12 ;** Fields at site
+13 FOR FILE=396.1,396.12,396.13,396.14,396.115
Begin DoDot:1
+14 FOR FLDDA=0:0
SET FLDDA=$ORDER(^DD(FILE,FLDDA))
if 'FLDDA
QUIT
Begin DoDot:2
+15 IF $DATA(^DD(FILE,FLDDA,0))
IF '$DATA(CLASSI(FILE,FLDDA))
Begin DoDot:3
+16 SET CLASSIII(FILE,FLDDA)=$PIECE(^DD(FILE,FLDDA,0),"^",1)_"^"_$PIECE(^(0),"^",4)
End DoDot:3
End DoDot:2
End DoDot:1
+17 ;
+18 ;** If no Class III fields
+19 IF '$DATA(CLASSIII)
Begin DoDot:1
+20 DO MES^XPDUTL(" ")
+21 DO MES^XPDUTL(".....no unsupported fields were found!")
End DoDot:1
+22 ;
+23 ;** Nullify all XPDQUES nodes
+24 SET QUESSUB=""
+25 FOR
SET QUESSUB=$ORDER(XPDQUES(QUESSUB))
if (QUESSUB']"")
QUIT
Begin DoDot:1
+26 SET XPDQUES(QUESSUB)=""
+27 SET XPDQUES(QUESSUB,"A")=""
End DoDot:1
+28 ;
+29 ;** Set up XPDQUES nodes
+30 SET FILE=""
+31 FOR
SET FILE=$ORDER(CLASSIII(FILE))
if ('FILE!($DATA(DVBAOUT)))
QUIT
Begin DoDot:1
+32 SET FLDDA=""
+33 FOR
SET FLDDA=$ORDER(CLASSIII(FILE,FLDDA))
if ('FLDDA!($DATA(DVBAOUT)))
QUIT
Begin DoDot:2
+34 WRITE !!!,?1,"Field #",?12,"Field Name",?45,"Node;Piece"
+35 WRITE !,?3,FLDDA
+36 WRITE ?12,$PIECE(CLASSIII(FILE,FLDDA),U,1)
+37 WRITE ?48,$PIECE(CLASSIII(FILE,FLDDA),U,2)
+38 SET DIR(0)="YAO^"
SET DIR("A")="Do you want to delete this field? "
+39 SET DIR("B")="YES"
DO ^DIR
+40 IF $DATA(DTOUT)!($DATA(DUOUT)!($DATA(DIROUT)))
SET DVBAOUT=""
+41 IF '$DATA(DVBAOUT)&(+Y=1)
Begin DoDot:3
+42 SET QUESDA=QUESDA+1
+43 SET QUESSUB="PRE"_QUESDA
+44 SET XPDQUES(QUESSUB)=$PIECE(CLASSIII(FILE,FLDDA),U,1)_"^"_FLDDA_"^"_FILE
+45 SET XPDQUES(QUESSUB,"A")=$PIECE(CLASSIII(FILE,FLDDA),U,1)_" selected for deletion!"
End DoDot:3
+46 KILL DIR,X,Y
End DoDot:2
End DoDot:1
+47 IF $DATA(DVBAOUT)
KILL XPDQUES
+48 IF '$DATA(DVBAOUT)
DO MAIL
KVARS KILL COUNT,DFN,I,NODE,NODENM,FIELDVAR,FLDDA,FILE,QUESDA
+1 KILL CLASSI,CLASSIII,DVBAOUT
+2 KILL DTOUT,DUOUT,DIROUT
+3 QUIT
+4 ;
MAIL ; mail message of bogus nodes found
+1 NEW DIFROM
+2 SET XMY(DUZ)=""
SET XMDUZ=.5
+3 SET XMSUB="AMIE SITE PARAMETER file field cleanup"
+4 SET XMTEXT="^TMP(""DVBA V2.7 P8 E-MAIL"","_$JOB_","
+5 SET I=0
SET COUNT=0
+6 SET TEXT="This Mailman message records the Class III fields selected for deletion"
+7 DO LINE(TEXT)
+8 SET TEXT=" with patch DVBA*2.7*8. These fields are only deleted if/when the"
+9 DO LINE(TEXT)
+10 SET TEXT=" installation was/is completed."
+11 DO LINE(TEXT)
+12 DO LINE(" ")
+13 SET TEXT=" The following fields were selected to delete from the AMIE SITE"
+14 DO LINE(TEXT)
+15 SET TEXT=" PARAMETER file (#396.1) (Multiples included):"
+16 DO LINE(TEXT)
+17 DO LINE(" ")
+18 IF '$DATA(XPDQUES)
Begin DoDot:1
+19 SET TEXT=" No fields selected for deletion!"
+20 DO LINE(TEXT)
End DoDot:1
+21 IF $DATA(XPDQUES("PRE1"))
IF (XPDQUES("PRE1")="")
Begin DoDot:1
+22 SET TEXT=" No fields selected for deletion!"
+23 DO LINE(TEXT)
End DoDot:1
+24 IF $DATA(XPDQUES("PRE1"))
IF (XPDQUES("PRE1")'="")
Begin DoDot:1
+25 SET TEXT=" FIELD NAME FIELD # FILE #"
+26 DO LINE(TEXT)
+27 SET TEXT=" ========== ======= ======"
+28 DO LINE(TEXT)
+29 SET I="PRE0"
+30 FOR
SET I=$ORDER(XPDQUES(I))
if (I']"")
QUIT
Begin DoDot:2
+31 SET (BLANK1,BLANK2)=""
+32 SET $PIECE(BLANK1," ",(37-$LENGTH($PIECE(XPDQUES(I),"^",1))))=""
+33 SET TEXT=" "_$PIECE(XPDQUES(I),"^",1)_BLANK1_$PIECE(XPDQUES(I),"^",2)
+34 SET $PIECE(BLANK2," ",(53-$LENGTH(TEXT)))=""
+35 SET TEXT=TEXT_BLANK2_$PIECE(XPDQUES(I),"^",3)
+36 DO LINE(TEXT)
End DoDot:2
End DoDot:1
+37 DO ^XMD
+38 KILL XMDUZ,XMY,XMTEXT,XMSUB,BLANK1,BLANK2,TEXT,QUESSUB
+39 KILL ^TMP("DVBA V2.7 P8 E-MAIL",$JOB)
+40 QUIT
+41 ;
+42 ;
LINE(TEXT) ; add line to array for e-mail
+1 SET COUNT=COUNT+1
SET ^TMP("DVBA V2.7 P8 E-MAIL",$JOB,COUNT)=TEXT
+2 QUIT
+3 ;
FLDCLEAN ;**Delete selected fields
+1 IF $DATA(XPDQUES)
Begin DoDot:1
+2 NEW I,SITEDA,MULTDA,FLDDA,FILEDA1,NODE,CLEANFLD
+3 SET SITEDA=0
+4 SET SITEDA=$ORDER(^DVB(396.1,SITEDA))
+5 SET I="PRE0"
+6 FOR
SET I=$ORDER(XPDQUES(I))
if (I']"")
QUIT
if (XPDQUES(I)="")
QUIT
Begin DoDot:2
+7 SET FILEDA1=$PIECE(XPDQUES(I),"^",3)
+8 SET FLDDA=$PIECE(XPDQUES(I),"^",2)
+9 ;
+10 ;** Remove data in fields deleted
+11 IF FILEDA1=396.1
Begin DoDot:3
+12 SET DIE="^DVB(396.1,"
SET DA=SITEDA
+13 SET DR=FLDDA_"////@"
+14 DO ^DIE
+15 KILL DIE,DA,DR
End DoDot:3
+16 IF FILEDA1'=396.1
Begin DoDot:3
+17 SET (CLEANFLD,MULTDA)=0
+18 SET MULTDA=$ORDER(^DD(396.1,"SB",FILEDA1,0))
+19 if MULTDA
SET CLEANFLD=1
SET NODE=$PIECE($PIECE(^DD(396.1,MULTDA,0),"^",4),";",1)
+20 IF CLEANFLD
Begin DoDot:4
+21 SET MULTDA=0
+22 FOR
SET MULTDA=$ORDER(^DVB(396.1,SITEDA,NODE,MULTDA))
if 'MULTDA
QUIT
Begin DoDot:5
+23 SET DIE="^DVB(396.1,"_SITEDA_","_NODE_","
+24 SET DA=MULTDA
SET DA(1)=SITEDA
+25 SET DR=FLDDA_"////@"
+26 DO ^DIE
+27 KILL DIE,DA,DR
End DoDot:5
End DoDot:4
End DoDot:3
+28 ;
+29 ;** Remove from DD
+30 SET DA=FLDDA
+31 SET DA(1)=FILEDA1
+32 SET DIK="^DD("_DA(1)_","
+33 DO ^DIK
+34 KILL DA,DIK
End DoDot:2
End DoDot:1
+35 QUIT
+36 ;
FIELDS ; list of fields in 396.1
+1 ;;.01
+2 ;;.11
+3 ;;2
+4 ;;3
+5 ;;4
+6 ;;6
+7 ;;7
+8 ;;8
+9 ;;9
+10 ;;10
+11 ;;11
+12 ;;12
+13 ;;14
+14 ;;15
+15 ;;16
+16 ;;17
+17 ;;18
+18 ;;50
+19 ;;90
+20 ;;QUIT
P12 ;;.01
+1 ;;QUIT
P13 ;;.01
+1 ;;1
+2 ;;QUIT
P14 ;;.01
+1 ;;1
+2 ;;QUIT
P115 ;;.01
+1 ;;QUIT
