BWPATCH8.m

BWPATCH8 ;IHS/CMI/LAB - BW PATCH 8 ;30-Jun-2003 22:42;PLS

 ;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996

 ;

 ;

ENV ; Check for duplicate RACE file entries

 ; 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

 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)

 Q

 ;

PRE ;

 N 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 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

 D MES("Preparing BW RACE (NBCCEDP) for updates...")

 S DIK="^BWRACE("

 S DA=0 F  S DA=$O(^BWRACE(DA)) Q:'DA  D

 .D ^DIK

 Q

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.

 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 FDA(2,9002086.02,BWDA_",",.51)=X

 . S FDA(2,9002086.02,BWDA_",",.52)=3021001

 . S:'$$GET1^DIQ(9002086.02,BWDA,.18,"I") FDA(2,9002086.02,BWDA_",",.18)=41

 . D 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 not 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

 ; 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

BWPATCH8  ;IHS/CMI/LAB - BW PATCH 8 ;30-Jun-2003 22:42;PLS

 +1       ;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996

 +2       ;

 +3       ;

ENV       ; Check for duplicate RACE file entries

 +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        NEW RVAL,IEN,DUP

 +5        SET RVAL=0

           FOR 

               SET RVAL=$ORDER(^DIC(10,"B",RVAL))

               IF RVAL=""

                   QUIT 

               Begin DoDot:1

 +6                SET IEN=$ORDER(^DIC(10,"B",RVAL,0))

 +7                IF $ORDER(^DIC(10,"B",RVAL,IEN))>0

                       SET DUP=1

               End DoDot:1

 +8        IF $GET(DUP)

               DO MES("THERE ARE DUPLICATE RACE VALUES IN THE RACE FILE!",1)

 +9        QUIT 

 +10      ;

PRE       ;

 +1        NEW 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       ; Purge entries in BW General Retrieval Items File

 +7        DO MES("Preparing BW GENERAL RETRIEVAL ITEMS File for new entries...")

 +8        SET DIK="^BWGRI("

 +9        SET DA=0

           FOR 

               SET DA=$ORDER(^BWGRI(DA))

               IF 'DA

                   QUIT 

               Begin DoDot:1

 +10               DO ^DIK

               End DoDot:1

 +11       DO MES("Preparing BW RACE (NBCCEDP) for updates...")

 +12       SET DIK="^BWRACE("

 +13       SET DA=0

           FOR 

               SET DA=$ORDER(^BWRACE(DA))

               IF 'DA

                   QUIT 

               Begin DoDot:1

 +14               DO ^DIK

               End DoDot:1

 +15       QUIT 

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        DO MES("Resolving Race File Pointers in BW RACE MAPPINGS (NBCCEDP) File.")

 +6        KILL ^BWRACE("B")

 +7        SET BWRIEN=0

 +8        FOR 

               SET BWRIEN=$ORDER(@XPDGREF@("RACEPTRS",BWRIEN))

               IF BWRIEN<1

                   QUIT 

               Begin DoDot:1

 +9                SET TXT=@XPDGREF@("RACEPTRS",BWRIEN)

 +10               DO MES("Processing entry: "_BWRIEN_" =  "_TXT)

 +11               SET $PIECE(^BWRACE(BWRIEN,0),U)=$ORDER(^DIC(10,"B",TXT,0))

               End DoDot:1

 +12      ; Re-index "B" x-ref of BW RACE MAPPINGS File

 +13       SET DIK="^BWRACE("

           SET DIK(1)=".01^B"

           DO ENALL^DIK

 +14      ;

 +15       SET BWDA=0

 +16       FOR 

               SET BWDA=$ORDER(^BWDIAG(BWDA))

               IF 'BWDA

                   QUIT 

               Begin DoDot:1

 +17               SET X=+$PIECE(^BWDIAG(BWDA,0),"^",24)

 +18               IF X<1

                       QUIT 

 +19               SET Y=$SELECT(X=2:1,X=3:2,X=4:3,X=7:8,X=14:7,1:X)

 +20               SET FDA(1,9002086.31,BWDA_",",.241)=Y

 +21               DO FILE^DIE("","FDA(1)","BWDIE(1)")

 +22               DO CLEAN^DILF

               End DoDot:1

 +23      ;

 +24      ; Set Bethesda 1991 (#.51) and 2001 (#.52) start dates in BW SITE file.

 +25      ; Set MDE version to 4.1 if no value is defined.

 +26       SET BWDA=0

 +27       FOR 

               SET BWDA=$ORDER(^BWSITE(BWDA))

               IF 'BWDA

                   QUIT 

               Begin DoDot:1

 +28               SET X=$PIECE(^BWSITE(BWDA,0),"^",17)

 +29               IF X<1

                       SET X=2910101

 +30               SET FDA(2,9002086.02,BWDA_",",.51)=X

 +31               SET FDA(2,9002086.02,BWDA_",",.52)=3021001

 +32               IF '$$GET1^DIQ(9002086.02,BWDA,.18,"I")

                       SET FDA(2,9002086.02,BWDA_",",.18)=41

 +33               DO FILE^DIE("","FDA(2)","BWDIE(2)")

 +34               DO CLEAN^DILF

               End DoDot:1

 +35      ; Importing Race into BW Patient File

 +36       DO MES("Importing Patient Race...")

 +37       DO START^BWUCVRC

 +38      ; Add procedure type to existing Wise Woman Procedures if needed

 +39      ;Site has not WW Procedures to correct

           IF '@XPDGREF@("WW")

               QUIT 

 +40       DO MES("Repairing Wise Woman procedures...")

 +41       SET BWDA=0

 +42       FOR 

               SET BWDA=$ORDER(^BWPCD(BWDA))

               IF 'BWDA

                   QUIT 

               Begin DoDot:1

 +43      ; Not a Wise Woman procedure

                   IF '$DATA(^BWPCD(BWDA,4))

                       QUIT 

 +44               WRITE "."

 +45               IF '$PIECE(^BWPCD(BWDA,0),U,4)

                       Begin DoDot:2

 +46                       WRITE ":"

 +47                       SET $PIECE(^BWPCD(BWDA,0),U,4)=39

                       End DoDot:2

               End DoDot:1

 +48       QUIT 

 +49      ; 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