BWPATCH9.m

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