XU8P469 ;ISF/RWF - Patch XU*8*469 post-init ;1/30/08 09:08
;;8.0;KERNEL;**469**;Jul 10, 1995;Build 7
POST ;Post-init to clean-up files
D MES^XPDUTL("Begin POST-INIT.")
D F19,EN1,EN2,SLOG
D MES^XPDUTL("Finished POST-INIT.")
Q
;
EN1 ;Change $N in file 200, field 9 to $O
D
. N ITRANS,PIECE
. S PIECE="$N(^VA(200,""SSN"",X,0))"
. S ITRANS=$P(^DD(200,9,0),U,5,99)
. I ITRANS'[PIECE Q ;Already altered Input Transform
. S ITRANS=$P(ITRANS,PIECE)_"$O(^VA(200,""SSN"",X,0))"_$P(ITRANS,PIECE,2)
. S $P(^DD(200,9,0),U,5,99)=ITRANS
. Q
Q
;
EN2 ;Now queue the removal of QAR fields and data.
;D MES^XPDUTL("Begin clean up of the NEW PERSON(#200) file...")
N ZTRTN,ZTDTH,ZTDESC,ZTSK,ZTIO
S ZTRTN="F200^XU8P469",ZTDTH=$H,ZTDESC="QAR data removal",ZTIO=""
D ^%ZTLOAD
D MES^XPDUTL("Queued the removal of QAR fields and data as task #"_ZTSK)
Q
;
SLOG ;Clean up any long last signon nodes.
N DA S DA=0
F S DA=$O(^VA(200,DA)) Q:'DA I $L($G(^VA(200,DA,1.1)),U)>5 D
. S ^VA(200,DA,1.1)=$P(^VA(200,DA,1.1),U,1,5)
. Q
Q
;
;From Cameron 2/9/2005
;Kernel should delete the whole range of fields from 747.1 through 747.9, all fields and all multiples between.
F200 ;Only remove if the pointed to files have been removed.
I $D(^DIC(747.25,0))!$D(DIC(747.5,0))!$D(^DIC(747.7,0)) Q
N FLD,DIU,DA,DIK
;First remove the multipuls
S FLD=747
;F FLD=.111,.13,.2,.27,.28,.31,.32,.34,.36,.43,.45,.5,.6,.7,.8 D
F S FLD=$O(^DD(200,FLD)) Q:FLD'["747." D
. S DIU(0)="S"
. I $D(^DD(200,FLD,0)),$P(^(0),U,2)>1 S DIU=+$P(^(0),U,2) D EN^DIU2
. Q
;Now remove the other fields.
S FLD=747
F S FLD=$O(^DD(200,FLD)) Q:FLD'["747." S DIK="^DD(200,",DA=FLD,DA(1)=200 D ^DIK
;
QAR ;Delete all QAR data from the NPF
N DA,ND
S DA=.5
F S DA=$O(^VA(200,DA)) Q:DA'>0 D
. S ND="QAQz"
. F S ND=$O(^VA(200,DA,ND)) Q:$E(ND,1,3)'="QAR" D
. . K ^VA(200,DA,ND)
. . Q
. Q
Q
;
F19 ;File 19 Field 24.
D MES^XPDUTL("Remove Field #24 from the OPTION(#19) file...")
I '$D(^DD(19,24,0))#2 D MES^XPDUTL("Field #24 is not defined.") G DONE
N DIK,DA
S DIK="^DD(19,",DA=24,DA(1)=19
D ^DIK
DONE D MES^XPDUTL("Finished cleaning up the OPTION(#19) file.")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXU8P469 2220 printed Dec 13, 2024@02:07:50 Page 2
XU8P469 ;ISF/RWF - Patch XU*8*469 post-init ;1/30/08 09:08
+1 ;;8.0;KERNEL;**469**;Jul 10, 1995;Build 7
POST ;Post-init to clean-up files
+1 DO MES^XPDUTL("Begin POST-INIT.")
+2 DO F19
DO EN1
DO EN2
DO SLOG
+3 DO MES^XPDUTL("Finished POST-INIT.")
+4 QUIT
+5 ;
EN1 ;Change $N in file 200, field 9 to $O
+1 Begin DoDot:1
+2 NEW ITRANS,PIECE
+3 SET PIECE="$N(^VA(200,""SSN"",X,0))"
+4 SET ITRANS=$PIECE(^DD(200,9,0),U,5,99)
+5 ;Already altered Input Transform
IF ITRANS'[PIECE
QUIT
+6 SET ITRANS=$PIECE(ITRANS,PIECE)_"$O(^VA(200,""SSN"",X,0))"_$PIECE(ITRANS,PIECE,2)
+7 SET $PIECE(^DD(200,9,0),U,5,99)=ITRANS
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
EN2 ;Now queue the removal of QAR fields and data.
+1 ;D MES^XPDUTL("Begin clean up of the NEW PERSON(#200) file...")
+2 NEW ZTRTN,ZTDTH,ZTDESC,ZTSK,ZTIO
+3 SET ZTRTN="F200^XU8P469"
SET ZTDTH=$HOROLOG
SET ZTDESC="QAR data removal"
SET ZTIO=""
+4 DO ^%ZTLOAD
+5 DO MES^XPDUTL("Queued the removal of QAR fields and data as task #"_ZTSK)
+6 QUIT
+7 ;
SLOG ;Clean up any long last signon nodes.
+1 NEW DA
SET DA=0
+2 FOR
SET DA=$ORDER(^VA(200,DA))
if 'DA
QUIT
IF $LENGTH($GET(^VA(200,DA,1.1)),U)>5
Begin DoDot:1
+3 SET ^VA(200,DA,1.1)=$PIECE(^VA(200,DA,1.1),U,1,5)
+4 QUIT
End DoDot:1
+5 QUIT
+6 ;
+7 ;From Cameron 2/9/2005
+8 ;Kernel should delete the whole range of fields from 747.1 through 747.9, all fields and all multiples between.
F200 ;Only remove if the pointed to files have been removed.
+1 IF $DATA(^DIC(747.25,0))!$DATA(DIC(747.5,0))!$DATA(^DIC(747.7,0))
QUIT
+2 NEW FLD,DIU,DA,DIK
+3 ;First remove the multipuls
+4 SET FLD=747
+5 ;F FLD=.111,.13,.2,.27,.28,.31,.32,.34,.36,.43,.45,.5,.6,.7,.8 D
+6 FOR
SET FLD=$ORDER(^DD(200,FLD))
if FLD'["747."
QUIT
Begin DoDot:1
+7 SET DIU(0)="S"
+8 IF $DATA(^DD(200,FLD,0))
IF $PIECE(^(0),U,2)>1
SET DIU=+$PIECE(^(0),U,2)
DO EN^DIU2
+9 QUIT
End DoDot:1
+10 ;Now remove the other fields.
+11 SET FLD=747
+12 FOR
SET FLD=$ORDER(^DD(200,FLD))
if FLD'["747."
QUIT
SET DIK="^DD(200,"
SET DA=FLD
SET DA(1)=200
DO ^DIK
+13 ;
QAR ;Delete all QAR data from the NPF
+1 NEW DA,ND
+2 SET DA=.5
+3 FOR
SET DA=$ORDER(^VA(200,DA))
if DA'>0
QUIT
Begin DoDot:1
+4 SET ND="QAQz"
+5 FOR
SET ND=$ORDER(^VA(200,DA,ND))
if $EXTRACT(ND,1,3)'="QAR"
QUIT
Begin DoDot:2
+6 KILL ^VA(200,DA,ND)
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
F19 ;File 19 Field 24.
+1 DO MES^XPDUTL("Remove Field #24 from the OPTION(#19) file...")
+2 IF '$DATA(^DD(19,24,0))#2
DO MES^XPDUTL("Field #24 is not defined.")
GOTO DONE
+3 NEW DIK,DA
+4 SET DIK="^DD(19,"
SET DA=24
SET DA(1)=19
+5 DO ^DIK
DONE DO MES^XPDUTL("Finished cleaning up the OPTION(#19) file.")
+1 QUIT
