BWPATCH9 ;IHS/CIA/DKM/PLS - KIDS Inits- Patch 9;19-Oct-2003 07:13;PLS
;;2.0;WOMEN'S HEALTH;**9**;MAY 16, 1996
; Environment check
EC D FIXIT
; The following line prevents the "Disable Options..." and "Move
; Routines..." questions from being asked during the install.
S XPDENV=1,(XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
; Check for duplicate RACE file entries
N RVAL,IEN,DUP
S RVAL=0 F S RVAL=$O(^DIC(10,"B",RVAL)) Q:RVAL="" D
.S IEN=$O(^DIC(10,"B",RVAL,0))
.S:$O(^DIC(10,"B",RVAL,IEN))>0 DUP=1
D:$G(DUP) MES("THERE ARE DUPLICATE RACE VALUES IN THE RACE FILE!",1)
;
;D:'$L($$GET1^DID(9002086,.09,"","LABEL")) MES("The verified version of patch BW*2.0*8 is required to continue!",1)
Q
; Pre-init
PRE ;
N BWFIEN,DIK,DA
S XPDENV=1,(XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
; Set Wise Woman Flag
; If flag =0 the fix in the post-init will not be run.
S @XPDGREF@("WW")=$D(^BWPN(39,0))
;
; Purge entries in BW RACE MAPPINGS (NBCCEDP) File
D MES("Preparing BW RACE MAPPINGS (NBCCEDP) for updates...")
S DIK="^BWRACE("
S DA=0 F S DA=$O(^BWRACE(DA)) Q:'DA D
.D ^DIK
;
; Purge entries in BW General Retrieval Items File
D MES("Preparing BW GENERAL RETRIEVAL ITEMS File for new entries...")
S DIK="^BWGRI("
S DA=0 F S DA=$O(^BWGRI(DA)) Q:'DA D
.D ^DIK
;
; Purge entries in BW MAMMOGRAPHY EXPORT DEFINITIONS File
D MES("Preparing BW MAMMOGRAPHY EXPORT DEFINITIONS File for new entries...")
S DIK="^BWMPEXP("
S DA=0 F S DA=$O(^BWMPEXP(DA)) Q:'DA D
.D ^DIK
;
; Remove BW EXPORT RECORD Form and associated Block(s)
S BWFIEN=$O(^DIST(.403,"B","BW EXPORT RECORD",0))
D:BWFIEN EN^DDSDFRM(BWFIEN)
Q
; Post-init
POST ; Converts (seeds) the new field CDC RESULTS OF PAP TEST (2001) (#.241) based on the existing
; field CDC RESULTS OF PAP TEST (1991) (#.24) (old field name CDC EQUIV SCREENING PAP DX) in
; file BW RESULTS/DIAGNOSIS (#9002086.31) to handle 2001 Bethesda System Categories.
;
N FDA,BWDA,BWDIE,X,Y,TXT,BWRIEN
;
D MES("Resolving Race File Pointers in BW RACE MAPPINGS (NBCCEDP) File.")
K ^BWRACE("B")
S BWRIEN=0
F S BWRIEN=$O(@XPDGREF@("RACEPTRS",BWRIEN)) Q:BWRIEN<1 D
.S TXT=@XPDGREF@("RACEPTRS",BWRIEN)
.D MES("Processing entry: "_BWRIEN_" = "_TXT)
.S $P(^BWRACE(BWRIEN,0),U)=$O(^DIC(10,"B",TXT,0))
; Re-index "B" x-ref of BW RACE MAPPINGS File
S DIK="^BWRACE(",DIK(1)=".01^B" D ENALL^DIK
;
S BWDA=0
F S BWDA=$O(^BWDIAG(BWDA)) Q:'BWDA D
. S X=+$P(^BWDIAG(BWDA,0),"^",24)
. I X<1 Q
. S Y=$S(X=2:1,X=3:2,X=4:3,X=7:8,X=14:7,1:X)
. S FDA(1,9002086.31,BWDA_",",.241)=Y
. D FILE^DIE("","FDA(1)","BWDIE(1)")
. D CLEAN^DILF
;
; Set Bethesda 1991 (#.51) and 2001 (#.52) start dates in BW SITE file.
; Set MDE version to 4.1 if no value is defined.
; Set Default Specimen Type
S BWDA=0
F S BWDA=$O(^BWSITE(BWDA)) Q:'BWDA D
. S X=$P(^BWSITE(BWDA,0),"^",17)
. I X<1 S X=2910101
. S:'$P($G(^BWSITE(BWDA,.51)),U) FDA(2,9002086.02,BWDA_",",.51)=X
. S:'$P($G(^BWSITE(BWDA,.51)),U,2) FDA(2,9002086.02,BWDA_",",.52)=3021001
. S:'$$GET1^DIQ(9002086.02,BWDA,.18,"I") FDA(2,9002086.02,BWDA_",",.18)=41
. S:'$$GET1^DIQ(9002086.02,BWDA,.24,"I") FDA(2,9002086.02,BWDA_",",.24)=1
. D:$D(FDA(2)) FILE^DIE("","FDA(2)","BWDIE(2)")
. D CLEAN^DILF
;
; Importing Race into BW Patient File
D MES("Importing Patient Race...")
D START^BWUCVRC
;
; Add procedure type to existing Wise Woman Procedures if needed
Q:'@XPDGREF@("WW") ;Site has no WW Procedures to correct
D MES("Repairing Wise Woman procedures...")
S BWDA=0
F S BWDA=$O(^BWPCD(BWDA)) Q:'BWDA D
.Q:'$D(^BWPCD(BWDA,4)) ; Not a Wise Woman procedure
.W "."
.I '$P(^BWPCD(BWDA,0),U,4) D
..W ":"
..S $P(^BWPCD(BWDA,0),U,4)=39
Q
; Delete DD for corrupted file #9002086.94 which is cross linked to
; same global as file #9002086.92. Must repoint 9002086.94 to a
; temporary global in order to delete safely.
FIXIT N $ET,DIU,BWFN,X
S $ET=""
S X="DELERR^BWMDEINI",@^%ZOSF("TRAP"),BWFN=9002086.94
Q:'$D(^DD(BWFN))
Q:$G(^DIC(BWFN,0,"GL"))="^BWFLT("
S ^DIC(BWFN,0,"GL")="^DIZ("_BWFN_",",^DIZ(BWFN,0)="BW EXPORT^"_BWFN
S DIU(0)="D",DIU=BWFN
D EN^DIU2
D:$D(^DD(BWFN)) SHOWERR("Access denied")
Q
DELERR D SHOWERR($$EC^%ZOSV)
Q
SHOWERR(ERR) ;
D MES("An error occurred deleting file #"_$G(BWFN))
D MES("The error was: "_ERR)
D MES("After correcting the problem, please try the installation again.")
S XPDQUIT=1
Q
;
; Display message in MSG and optionally set quit flag to QUIT
MES(MSG,QUIT) ;
D BMES^XPDUTL(" "_$G(MSG))
S:$G(QUIT) XPDQUIT=QUIT
Q
; Pre-Transport global for BW RACE file mappings
PRETRAN ;
N IEN,VAL,TXT
S IEN=0
F S IEN=$O(^BWRACE(IEN)) Q:IEN<1 D
.S VAL=$P(^BWRACE(IEN,0),U),TXT=$$GET1^DIQ(10,VAL,.01,"E")
.S @XPDGREF@("RACEPTRS",IEN)=TXT
Q
BWPATCH9 ;IHS/CIA/DKM/PLS - KIDS Inits- Patch 9;19-Oct-2003 07:13;PLS
+1 ;;2.0;WOMEN'S HEALTH;**9**;MAY 16, 1996
+2 ; Environment check
EC DO FIXIT
+1 ; The following line prevents the "Disable Options..." and "Move
+2 ; Routines..." questions from being asked during the install.
+3 SET XPDENV=1
SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+4 ; Check for duplicate RACE file entries
+5 NEW RVAL,IEN,DUP
+6 SET RVAL=0
FOR
SET RVAL=$ORDER(^DIC(10,"B",RVAL))
IF RVAL=""
QUIT
Begin DoDot:1
+7 SET IEN=$ORDER(^DIC(10,"B",RVAL,0))
+8 IF $ORDER(^DIC(10,"B",RVAL,IEN))>0
SET DUP=1
End DoDot:1
+9 IF $GET(DUP)
DO MES("THERE ARE DUPLICATE RACE VALUES IN THE RACE FILE!",1)
+10 ;
+11 ;D:'$L($$GET1^DID(9002086,.09,"","LABEL")) MES("The verified version of patch BW*2.0*8 is required to continue!",1)
+12 QUIT
+13 ; Pre-init
PRE ;
+1 NEW BWFIEN,DIK,DA
+2 SET XPDENV=1
SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+3 ; Set Wise Woman Flag
+4 ; If flag =0 the fix in the post-init will not be run.
+5 SET @XPDGREF@("WW")=$DATA(^BWPN(39,0))
+6 ;
+7 ; Purge entries in BW RACE MAPPINGS (NBCCEDP) File
+8 DO MES("Preparing BW RACE MAPPINGS (NBCCEDP) for updates...")
+9 SET DIK="^BWRACE("
+10 SET DA=0
FOR
SET DA=$ORDER(^BWRACE(DA))
IF 'DA
QUIT
Begin DoDot:1
+11 DO ^DIK
End DoDot:1
+12 ;
+13 ; Purge entries in BW General Retrieval Items File
+14 DO MES("Preparing BW GENERAL RETRIEVAL ITEMS File for new entries...")
+15 SET DIK="^BWGRI("
+16 SET DA=0
FOR
SET DA=$ORDER(^BWGRI(DA))
IF 'DA
QUIT
Begin DoDot:1
+17 DO ^DIK
End DoDot:1
+18 ;
+19 ; Purge entries in BW MAMMOGRAPHY EXPORT DEFINITIONS File
+20 DO MES("Preparing BW MAMMOGRAPHY EXPORT DEFINITIONS File for new entries...")
+21 SET DIK="^BWMPEXP("
+22 SET DA=0
FOR
SET DA=$ORDER(^BWMPEXP(DA))
IF 'DA
QUIT
Begin DoDot:1
+23 DO ^DIK
End DoDot:1
+24 ;
+25 ; Remove BW EXPORT RECORD Form and associated Block(s)
+26 SET BWFIEN=$ORDER(^DIST(.403,"B","BW EXPORT RECORD",0))
+27 IF BWFIEN
DO EN^DDSDFRM(BWFIEN)
+28 QUIT
+29 ; Post-init
POST ; Converts (seeds) the new field CDC RESULTS OF PAP TEST (2001) (#.241) based on the existing
+1 ; field CDC RESULTS OF PAP TEST (1991) (#.24) (old field name CDC EQUIV SCREENING PAP DX) in
+2 ; file BW RESULTS/DIAGNOSIS (#9002086.31) to handle 2001 Bethesda System Categories.
+3 ;
+4 NEW FDA,BWDA,BWDIE,X,Y,TXT,BWRIEN
+5 ;
+6 DO MES("Resolving Race File Pointers in BW RACE MAPPINGS (NBCCEDP) File.")
+7 KILL ^BWRACE("B")
+8 SET BWRIEN=0
+9 FOR
SET BWRIEN=$ORDER(@XPDGREF@("RACEPTRS",BWRIEN))
IF BWRIEN<1
QUIT
Begin DoDot:1
+10 SET TXT=@XPDGREF@("RACEPTRS",BWRIEN)
+11 DO MES("Processing entry: "_BWRIEN_" = "_TXT)
+12 SET $PIECE(^BWRACE(BWRIEN,0),U)=$ORDER(^DIC(10,"B",TXT,0))
End DoDot:1
+13 ; Re-index "B" x-ref of BW RACE MAPPINGS File
+14 SET DIK="^BWRACE("
SET DIK(1)=".01^B"
DO ENALL^DIK
+15 ;
+16 SET BWDA=0
+17 FOR
SET BWDA=$ORDER(^BWDIAG(BWDA))
IF 'BWDA
QUIT
Begin DoDot:1
+18 SET X=+$PIECE(^BWDIAG(BWDA,0),"^",24)
+19 IF X<1
QUIT
+20 SET Y=$SELECT(X=2:1,X=3:2,X=4:3,X=7:8,X=14:7,1:X)
+21 SET FDA(1,9002086.31,BWDA_",",.241)=Y
+22 DO FILE^DIE("","FDA(1)","BWDIE(1)")
+23 DO CLEAN^DILF
End DoDot:1
+24 ;
+25 ; Set Bethesda 1991 (#.51) and 2001 (#.52) start dates in BW SITE file.
+26 ; Set MDE version to 4.1 if no value is defined.
+27 ; Set Default Specimen Type
+28 SET BWDA=0
+29 FOR
SET BWDA=$ORDER(^BWSITE(BWDA))
IF 'BWDA
QUIT
Begin DoDot:1
+30 SET X=$PIECE(^BWSITE(BWDA,0),"^",17)
+31 IF X<1
SET X=2910101
+32 IF '$PIECE($GET(^BWSITE(BWDA,.51)),U)
SET FDA(2,9002086.02,BWDA_",",.51)=X
+33 IF '$PIECE($GET(^BWSITE(BWDA,.51)),U,2)
SET FDA(2,9002086.02,BWDA_",",.52)=3021001
+34 IF '$$GET1^DIQ(9002086.02,BWDA,.18,"I")
SET FDA(2,9002086.02,BWDA_",",.18)=41
+35 IF '$$GET1^DIQ(9002086.02,BWDA,.24,"I")
SET FDA(2,9002086.02,BWDA_",",.24)=1
+36 IF $DATA(FDA(2))
DO FILE^DIE("","FDA(2)","BWDIE(2)")
+37 DO CLEAN^DILF
End DoDot:1
+38 ;
+39 ; Importing Race into BW Patient File
+40 DO MES("Importing Patient Race...")
+41 DO START^BWUCVRC
+42 ;
+43 ; Add procedure type to existing Wise Woman Procedures if needed
+44 ;Site has no WW Procedures to correct
IF '@XPDGREF@("WW")
QUIT
+45 DO MES("Repairing Wise Woman procedures...")
+46 SET BWDA=0
+47 FOR
SET BWDA=$ORDER(^BWPCD(BWDA))
IF 'BWDA
QUIT
Begin DoDot:1
+48 ; Not a Wise Woman procedure
IF '$DATA(^BWPCD(BWDA,4))
QUIT
+49 WRITE "."
+50 IF '$PIECE(^BWPCD(BWDA,0),U,4)
Begin DoDot:2
+51 WRITE ":"
+52 SET $PIECE(^BWPCD(BWDA,0),U,4)=39
End DoDot:2
End DoDot:1
+53 QUIT
+54 ; Delete DD for corrupted file #9002086.94 which is cross linked to
+55 ; same global as file #9002086.92. Must repoint 9002086.94 to a
+56 ; temporary global in order to delete safely.
FIXIT NEW $ETRAP,DIU,BWFN,X
+1 SET $ETRAP=""
+2 SET X="DELERR^BWMDEINI"
SET @^%ZOSF("TRAP")
SET BWFN=9002086.94
+3 IF '$DATA(^DD(BWFN))
QUIT
+4 IF $GET(^DIC(BWFN,0,"GL"))="^BWFLT("
QUIT
+5 SET ^DIC(BWFN,0,"GL")="^DIZ("_BWFN_","
SET ^DIZ(BWFN,0)="BW EXPORT^"_BWFN
+6 SET DIU(0)="D"
SET DIU=BWFN
+7 DO EN^DIU2
+8 IF $DATA(^DD(BWFN))
DO SHOWERR("Access denied")
+9 QUIT
DELERR DO SHOWERR($$EC^%ZOSV)
+1 QUIT
SHOWERR(ERR) ;
+1 DO MES("An error occurred deleting file #"_$GET(BWFN))
+2 DO MES("The error was: "_ERR)
+3 DO MES("After correcting the problem, please try the installation again.")
+4 SET XPDQUIT=1
+5 QUIT
+6 ;
+7 ; Display message in MSG and optionally set quit flag to QUIT
MES(MSG,QUIT) ;
+1 DO BMES^XPDUTL(" "_$GET(MSG))
+2 IF $GET(QUIT)
SET XPDQUIT=QUIT
+3 QUIT
+4 ; Pre-Transport global for BW RACE file mappings
PRETRAN ;
+1 NEW IEN,VAL,TXT
+2 SET IEN=0
+3 FOR
SET IEN=$ORDER(^BWRACE(IEN))
IF IEN<1
QUIT
Begin DoDot:1
+4 SET VAL=$PIECE(^BWRACE(IEN,0),U)
SET TXT=$$GET1^DIQ(10,VAL,.01,"E")
+5 SET @XPDGREF@("RACEPTRS",IEN)=TXT
End DoDot:1
+6 QUIT
