- XU8P469 ;ISF/RWF - Patch XU*8*469 post-init ;1/30/08 09:08
- ;;8.0;KERNEL;**469**;Jul 10, 1995;Build 16
- 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
- XU8P469 ;ISF/RWF - Patch XU*8*469 post-init ;1/30/08 09:08
- +1 ;;8.0;KERNEL;**469**;Jul 10, 1995;Build 16
- 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
