BWPTCH11.m

BWPTCH11 ;IHS/CMI/LAB - BW PATCH 11 ;6-Jan-2009 12:14;PLS

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

 ;

 ;

PRE ;

 S DIU=9002086.34,DIU(0)="" D EN^DIU2

 Q

POST ;

 ; Add version 6.0 to the MDE multiple in the race mappings file.

 N BWRIEN,BWCODE,BWSITE,DR,BWREC,BWDAT,BWNEWDX,BWUSEDX,BWUIEN,BWDX0,NBWDX0,J,NEWIEN,I,BWPIEN

 I $$PATCH^XPDUTL("BW*2.0*11") W "POST INSTALL WILL NOT RUN AGAIN" Q

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

 .I $D(^BWRACE(BWRIEN,1,"AC",50)) D

 ..S BWCODE=$O(^BWRACE(BWRIEN,1,"AC",50,0)) Q:'BWCODE

 ..S FDA(9002086.341,"+1,"_BWRIEN_",",.01)=60 D UPDATE^DIE(,"FDA","NEWIEN") K FDA

 ..I $D(NEWIEN) D

 ...S FDA(9002086.341,NEWIEN(1)_","_BWRIEN_",",1)=BWCODE D FILE^DIE(,"FDA") K NEWIEN,FDA

 ;

 ; Add 6.0 to the MDE Version multiple in the BW SITE PARAMETER file.

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

 .;I $$GET1^DIQ(9002086.02,BWSITE,.18,"I")'=50 Q

 .S DR=".18///"_60 D DIE^BWFMAN(9002086.02,DR,BWSITE,.BWPOP)

 ;

 ; Update the BW RESULTS/DIAGNOSIS file with new BI-RAD codes.

P2 F I=25,26,28 D CLN(I)

 F I=1:1 D  Q:BWREC=" Q"

 .S BWREC=$T(DIAG+I) Q:'$L(BWREC)

 .S BWDAT=$P(BWREC,";;",2)

 .S BWNEWDX=$P(BWDAT,":"),BWUSEDX=$P(BWDAT,":",2),BWDXPRCS=$P(BWDAT,":",3) Q:BWNEWDX=""

 .; If the new DX already exists, do not create another entry. Update the existing entry

 .; to be sure that the data in the entry is correct.

 .I $D(^BWDIAG("B",BWNEWDX)) D  Q

 ..S BWPIEN=$O(^BWDIAG("B",BWNEWDX,0))

 ..D ADDPRCS(BWDXPRCS,.BWDX0)

 ..S $P(^BWDIAG(BWPIEN,0),U,3)=BWDX0

 ..S $P(^BWDIAG(BWPIEN,0),U,20)=0

 ..S $P(^BWDIAG(BWPIEN,0),U,25)=$P(BWDAT,":",5)

 ..D REINDEX(BWPIEN)

 .I BWUSEDX="" D  Q

 ..S BWDX0=""

 ..S FDA(9002086.31,"+1,",.01)=BWNEWDX

 ..S FDA(9002086.31,"+1,",.02)=$P(BWDAT,":",4) D UPDATE^DIE(,"FDA","NEWIEN") K FDA

 ..I $D(NEWIEN) D

 ...D ADDPRCS(BWDXPRCS,.BWDX0)

 ...S $P(^BWDIAG(NEWIEN(1),0),U,3)=BWDX0

 ...S $P(^BWDIAG(NEWIEN(1),0),U,20)=0

 ...S $P(^BWDIAG(NEWIEN(1),0),U,25)=$P(BWDAT,":",5)

 ...S DIK="^BWDIAG(",DA=NEWIEN(1) D IX^DIK K NEWIEN

 .S BWUIEN=$O(^BWDIAG("B",BWUSEDX,0)) Q:'BWUIEN

 .S BWPRI=$P(^BWDIAG(BWUIEN,0),U,2)

 .S BWDX0=$P(^BWDIAG(BWUIEN,0),U,3,99)

 .S BWPRC=""

 .D ADDPRCS(BWDXPRCS,.BWDX0)

 .S FDA(9002086.31,"+1,",.01)=BWNEWDX

 .S FDA(9002086.31,"+1,",.02)=BWPRI

 .D UPDATE^DIE(,"FDA","NEWIEN") K FDA

 .I $D(NEWIEN) D

 ..S $P(^BWDIAG(NEWIEN(1),0),U,3)=BWDX0

 .D REINDEX(NEWIEN(1))

 .D REINDEX(BWUIEN)

 .K BWDX0,NEWIEN,DIK,DA

 D UPDHPV

 K ^BWDIAG("P")

 S DIK="^BWDIAG(" D IXALL^DIK

 Q

 ; Add CDC Equiv. HPV results. If the result type already exists, just update the new field value.

REINDEX(IEN) ;

 S DIK="^BWDIAG(",DA=IEN D IX^DIK

 Q

UPDHPV ;

 N I,DATA,RESDAT,RES,CDCVAL,PRIO,DR,FDA

 D CLN(40)

 F I=1:1 D  Q:DATA=" Q"

 .S DATA=$T(HPV+I) Q:DATA=" Q"

 .S RESDAT=$P(DATA,";;",2) Q:RESDAT=""

 .S RES=$P(RESDAT,":"),CDCVAL=$P(RESDAT,":",2),PRIO=$P(RESDAT,":",3)

 .I $D(^BWDIAG("B",RES)) D  Q

 ..S RESIEN=$O(^BWDIAG("B",RES,0))

 ..S DR="1///"_CDCVAL D DIE^BWFMAN(9002086.31,DR,RESIEN,.BWPOP)

 ..D ADDHPV(RESIEN)

 ..S DIK="^BWDIAG(",DA=RESIEN D IX^DIK

 .S FDA(9002086.31,"+1,",.01)=RES

 .S FDA(9002086.31,"+1,",.02)=PRIO

 .S FDA(9002086.31,"+1,",1)=CDCVAL

 .D UPDATE^DIE(,"FDA","NEWIEN") K FDA

 .I '$D(NEWIEN) Q

 .S RESIEN=$G(NEWIEN(1))

 .D ADDHPV(RESIEN)

 .S DIK="^BWDIAG(",DA=RESIEN D IX^DIK

 .K NEWIEN

 Q

 ; Clean up old entries with pointers to value passed in.

 ; INPUT : PRIEN - The value pointed to by the ASSOCIATED PROCEDURE portion of the BW RESULT/DIAGNOSIS file.

CLN(PRIEN) ;

 N BWIEN,I,VAL,J,NODE,DIK,DA,ARY

 Q:'PRIEN

 S BWIEN=0 F  S BWIEN=$O(^BWDIAG(BWIEN)) Q:'BWIEN  D

 .K ARY

 .F I=3:1:19 D

 ..S VAL=$P(^BWDIAG(BWIEN,0),U,I) I VAL S ARY(VAL)=""

 .I '$D(ARY(PRIEN)) Q

 .F I=3:1:19 S $P(^BWDIAG(BWIEN,0),U,I)=""

 .K ARY(PRIEN) I '$O(ARY(0)) Q

 .S NODE=3

 .S J=0 F  S J=$O(ARY(J)) Q:'J  D

 ..S $P(^BWDIAG(BWIEN,0),U,NODE)=J,NODE=NODE+1

 .;S DIK="^BWDIAG(",DA=BWIEN D IX^DIK

 Q

 ; Add HPV procedure to this diagnosis

ADDHPV(RESIEN) ;

 N I,VAL,DONE,SETPC

 S (DONE,SETPC)=0

 F I=3:1:19 D  Q:DONE

 .S VAL=$P(^BWDIAG(RESIEN,0),U,I)

 .I VAL=$O(^BWPN("B","HPV SCREEN",0)) S DONE=1 Q

 .I 'VAL S DONE=1,SETPC=I Q

 Q:'SETPC

 S $P(^BWDIAG(RESIEN,0),U,SETPC)=$O(^BWPN("B","HPV SCREEN",0))

 Q

 ; Add procedures to new code

ADDPRCS(BWDXPRCS,BWDX0) ;

 N J,PC,BWPRC,DONE

 S BWPRC=""

 F J=1:1:17 D  Q:BWPRC=""

 .S BWPRC=$P(BWDXPRCS,",",J) Q:BWPRC=""

 .S BWPRCIEN=$O(^BWPN("B",BWPRC,0))

 .S $P(BWDX0,U,J)=BWPRCIEN

 ; find the first blank entry and add IEN for VAGINAL ULTRASOUND

 S DONE=0

 F K=1:1:17 D  Q:DONE

 .; If this is already part of the BU result set, quit.

 .I $P(BWDX0,U,K)=$O(^BWPN("B","BREAST ULTRASOUND",0)) S DONE=1 Q

 .I $P(BWDX0,U,K) Q

 .S $P(BWDX0,U,K)=$O(^BWPN("B","BREAST ULTRASOUND",0)),DONE=1

 Q

 ; Remove procedure from old code

REMPRCS(BWDXPRCS,BWUIEN) ;

 N I,ARY,BWPRC,BWPRCIEN,A,TARY,PIECE,ITEM,LOOP

 ; build array of items to be removed

 F A=1:1:17 D  Q:BWPRC=""

 .S BWPRC=$P(BWDXPRCS,",",A) Q:BWPRC=""

 .S BWPRCIEN=$O(^BWPN("B",BWPRC,0))

 .S TARY(BWPRCIEN)=""

 ; build array of items currently defined for the result/diagnosis and remove all items from this result/diagnosis

 F I=3:1:19 D

 .S VAL=$P(^BWDIAG(BWUIEN,0),U,I) Q:'VAL

 .S ARY(I)=VAL,$P(^BWDIAG(BWUIEN,0),U,I)="" S DIK="^BWDIAG(",DA=BWUIEN D IX2^DIK Q

 ; put the diagnosis items back in, but if the ARY contains one of the values in TARY, skip it, as this is to be removed.

 S PIECE=3

 S LOOP=0 F  S LOOP=$O(ARY(LOOP)) Q:'LOOP  D

 .S ITEM=$G(ARY(LOOP))

 .I $D(TARY(ITEM)) Q

 .S $P(^BWDIAG(BWUIEN,0),U,PIECE)=$G(ARY(LOOP))

 .S PIECE=PIECE+1

 Q

DIAG ;

 ;;BI-RADS 0-Add Imag Eval Needed::MAMMOGRAM DX BILAT,MAMMOGRAM DX UNILAT,MAMMOGRAM SCREENING:6:13

 ;;BI-RADS 1:Negative:MAMMOGRAM DX BILAT,MAMMOGRAM DX UNILAT,MAMMOGRAM SCREENING

 ;;BI-RADS 2:Benign Finding, Negative:MAMMOGRAM DX BILAT,MAMMOGRAM DX UNILAT,MAMMOGRAM SCREENING

 ;;BI-RADS 3:Prbly Benign, Short Int F/U:MAMMOGRAM DX BILAT,MAMMOGRAM DX UNILAT,MAMMOGRAM SCREENING

 ;;BI-RADS 4:Suspicious Abnorm, Consider Bx:MAMMOGRAM DX BILAT,MAMMOGRAM DX UNILAT,MAMMOGRAM SCREENING

 ;;BI-RADS 5:Highly Sug of Malig, Tk Action:MAMMOGRAM DX BILAT,MAMMOGRAM DX UNILAT,MAMMOGRAM SCREENING

 ;;BI-RADS 0-Prev Films Req:Incomplete, Previous Films Req:MAMMOGRAM DX BILAT,MAMMOGRAM DX UNILAT,MAMMOGRAM SCREENING:7

 Q

HPV ;

 ;;Positive:1:10

 ;;Negative:2:20

 ;;Test Not Done:3:30

 ;;Unknown:9:90

 Q

BWPTCH11  ;IHS/CMI/LAB - BW PATCH 11 ;6-Jan-2009 12:14;PLS

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

 +2       ;

 +3       ;

PRE       ;

 +1        SET DIU=9002086.34

           SET DIU(0)=""

           DO EN^DIU2

 +2        QUIT 

POST      ;

 +1       ; Add version 6.0 to the MDE multiple in the race mappings file.

 +2        NEW BWRIEN,BWCODE,BWSITE,DR,BWREC,BWDAT,BWNEWDX,BWUSEDX,BWUIEN,BWDX0,NBWDX0,J,NEWIEN,I,BWPIEN

 +3        IF $$PATCH^XPDUTL("BW*2.0*11")

               WRITE "POST INSTALL WILL NOT RUN AGAIN"

               QUIT 

 +4        SET BWRIEN=0

           FOR 

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

               IF 'BWRIEN

                   QUIT 

               Begin DoDot:1

 +5                IF $DATA(^BWRACE(BWRIEN,1,"AC",50))

                       Begin DoDot:2

 +6                        SET BWCODE=$ORDER(^BWRACE(BWRIEN,1,"AC",50,0))

                           IF 'BWCODE

                               QUIT 

 +7                        SET FDA(9002086.341,"+1,"_BWRIEN_",",.01)=60

                           DO UPDATE^DIE(,"FDA","NEWIEN")

                           KILL FDA

 +8                        IF $DATA(NEWIEN)

                               Begin DoDot:3

 +9                                SET FDA(9002086.341,NEWIEN(1)_","_BWRIEN_",",1)=BWCODE

                                   DO FILE^DIE(,"FDA")

                                   KILL NEWIEN,FDA

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +10      ;

 +11      ; Add 6.0 to the MDE Version multiple in the BW SITE PARAMETER file.

 +12       SET BWSITE=0

           FOR 

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

               IF 'BWSITE

                   QUIT 

               Begin DoDot:1

 +13      ;I $$GET1^DIQ(9002086.02,BWSITE,.18,"I")'=50 Q

 +14               SET DR=".18///"_60

                   DO DIE^BWFMAN(9002086.02,DR,BWSITE,.BWPOP)

               End DoDot:1

 +15      ;

 +16      ; Update the BW RESULTS/DIAGNOSIS file with new BI-RAD codes.

P2         FOR I=25,26,28

               DO CLN(I)

 +1        FOR I=1:1

               Begin DoDot:1

 +2                SET BWREC=$TEXT(DIAG+I)

                   IF '$LENGTH(BWREC)

                       QUIT 

 +3                SET BWDAT=$PIECE(BWREC,";;",2)

 +4                SET BWNEWDX=$PIECE(BWDAT,":")

                   SET BWUSEDX=$PIECE(BWDAT,":",2)

                   SET BWDXPRCS=$PIECE(BWDAT,":",3)

                   IF BWNEWDX=""

                       QUIT 

 +5       ; If the new DX already exists, do not create another entry. Update the existing entry

 +6       ; to be sure that the data in the entry is correct.

 +7                IF $DATA(^BWDIAG("B",BWNEWDX))

                       Begin DoDot:2

 +8                        SET BWPIEN=$ORDER(^BWDIAG("B",BWNEWDX,0))

 +9                        DO ADDPRCS(BWDXPRCS,.BWDX0)

 +10                       SET $PIECE(^BWDIAG(BWPIEN,0),U,3)=BWDX0

 +11                       SET $PIECE(^BWDIAG(BWPIEN,0),U,20)=0

 +12                       SET $PIECE(^BWDIAG(BWPIEN,0),U,25)=$PIECE(BWDAT,":",5)

 +13                       DO REINDEX(BWPIEN)

                       End DoDot:2

                       QUIT 

 +14               IF BWUSEDX=""

                       Begin DoDot:2

 +15                       SET BWDX0=""

 +16                       SET FDA(9002086.31,"+1,",.01)=BWNEWDX

 +17                       SET FDA(9002086.31,"+1,",.02)=$PIECE(BWDAT,":",4)

                           DO UPDATE^DIE(,"FDA","NEWIEN")

                           KILL FDA

 +18                       IF $DATA(NEWIEN)

                               Begin DoDot:3

 +19                               DO ADDPRCS(BWDXPRCS,.BWDX0)

 +20                               SET $PIECE(^BWDIAG(NEWIEN(1),0),U,3)=BWDX0

 +21                               SET $PIECE(^BWDIAG(NEWIEN(1),0),U,20)=0

 +22                               SET $PIECE(^BWDIAG(NEWIEN(1),0),U,25)=$PIECE(BWDAT,":",5)

 +23                               SET DIK="^BWDIAG("

                                   SET DA=NEWIEN(1)

                                   DO IX^DIK

                                   KILL NEWIEN

                               End DoDot:3

                       End DoDot:2

                       QUIT 

 +24               SET BWUIEN=$ORDER(^BWDIAG("B",BWUSEDX,0))

                   IF 'BWUIEN

                       QUIT 

 +25               SET BWPRI=$PIECE(^BWDIAG(BWUIEN,0),U,2)

 +26               SET BWDX0=$PIECE(^BWDIAG(BWUIEN,0),U,3,99)

 +27               SET BWPRC=""

 +28               DO ADDPRCS(BWDXPRCS,.BWDX0)

 +29               SET FDA(9002086.31,"+1,",.01)=BWNEWDX

 +30               SET FDA(9002086.31,"+1,",.02)=BWPRI

 +31               DO UPDATE^DIE(,"FDA","NEWIEN")

                   KILL FDA

 +32               IF $DATA(NEWIEN)

                       Begin DoDot:2

 +33                       SET $PIECE(^BWDIAG(NEWIEN(1),0),U,3)=BWDX0

                       End DoDot:2

 +34               DO REINDEX(NEWIEN(1))

 +35               DO REINDEX(BWUIEN)

 +36               KILL BWDX0,NEWIEN,DIK,DA

               End DoDot:1

               IF BWREC=" Q"

                   QUIT 

 +37       DO UPDHPV

 +38       KILL ^BWDIAG("P")

 +39       SET DIK="^BWDIAG("

           DO IXALL^DIK

 +40       QUIT 

 +41      ; Add CDC Equiv. HPV results. If the result type already exists, just update the new field value.

REINDEX(IEN) ;

 +1        SET DIK="^BWDIAG("

           SET DA=IEN

           DO IX^DIK

 +2        QUIT 

UPDHPV    ;

 +1        NEW I,DATA,RESDAT,RES,CDCVAL,PRIO,DR,FDA

 +2        DO CLN(40)

 +3        FOR I=1:1

               Begin DoDot:1

 +4                SET DATA=$TEXT(HPV+I)

                   IF DATA=" Q"

                       QUIT 

 +5                SET RESDAT=$PIECE(DATA,";;",2)

                   IF RESDAT=""

                       QUIT 

 +6                SET RES=$PIECE(RESDAT,":")

                   SET CDCVAL=$PIECE(RESDAT,":",2)

                   SET PRIO=$PIECE(RESDAT,":",3)

 +7                IF $DATA(^BWDIAG("B",RES))

                       Begin DoDot:2

 +8                        SET RESIEN=$ORDER(^BWDIAG("B",RES,0))

 +9                        SET DR="1///"_CDCVAL

                           DO DIE^BWFMAN(9002086.31,DR,RESIEN,.BWPOP)

 +10                       DO ADDHPV(RESIEN)

 +11                       SET DIK="^BWDIAG("

                           SET DA=RESIEN

                           DO IX^DIK

                       End DoDot:2

                       QUIT 

 +12               SET FDA(9002086.31,"+1,",.01)=RES

 +13               SET FDA(9002086.31,"+1,",.02)=PRIO

 +14               SET FDA(9002086.31,"+1,",1)=CDCVAL

 +15               DO UPDATE^DIE(,"FDA","NEWIEN")

                   KILL FDA

 +16               IF '$DATA(NEWIEN)

                       QUIT 

 +17               SET RESIEN=$GET(NEWIEN(1))

 +18               DO ADDHPV(RESIEN)

 +19               SET DIK="^BWDIAG("

                   SET DA=RESIEN

                   DO IX^DIK

 +20               KILL NEWIEN

               End DoDot:1

               IF DATA=" Q"

                   QUIT 

 +21       QUIT 

 +22      ; Clean up old entries with pointers to value passed in.

 +23      ; INPUT : PRIEN - The value pointed to by the ASSOCIATED PROCEDURE portion of the BW RESULT/DIAGNOSIS file.

CLN(PRIEN) ;

 +1        NEW BWIEN,I,VAL,J,NODE,DIK,DA,ARY

 +2        IF 'PRIEN

               QUIT 

 +3        SET BWIEN=0

           FOR 

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

               IF 'BWIEN

                   QUIT 

               Begin DoDot:1

 +4                KILL ARY

 +5                FOR I=3:1:19

                       Begin DoDot:2

 +6                        SET VAL=$PIECE(^BWDIAG(BWIEN,0),U,I)

                           IF VAL

                               SET ARY(VAL)=""

                       End DoDot:2

 +7                IF '$DATA(ARY(PRIEN))

                       QUIT 

 +8                FOR I=3:1:19

                       SET $PIECE(^BWDIAG(BWIEN,0),U,I)=""

 +9                KILL ARY(PRIEN)

                   IF '$ORDER(ARY(0))

                       QUIT 

 +10               SET NODE=3

 +11               SET J=0

                   FOR 

                       SET J=$ORDER(ARY(J))

                       IF 'J

                           QUIT 

                       Begin DoDot:2

 +12                       SET $PIECE(^BWDIAG(BWIEN,0),U,NODE)=J

                           SET NODE=NODE+1

                       End DoDot:2

 +13      ;S DIK="^BWDIAG(",DA=BWIEN D IX^DIK

               End DoDot:1

 +14       QUIT 

 +15      ; Add HPV procedure to this diagnosis

ADDHPV(RESIEN) ;

 +1        NEW I,VAL,DONE,SETPC

 +2        SET (DONE,SETPC)=0

 +3        FOR I=3:1:19

               Begin DoDot:1

 +4                SET VAL=$PIECE(^BWDIAG(RESIEN,0),U,I)

 +5                IF VAL=$ORDER(^BWPN("B","HPV SCREEN",0))

                       SET DONE=1

                       QUIT 

 +6                IF 'VAL

                       SET DONE=1

                       SET SETPC=I

                       QUIT 

               End DoDot:1

               IF DONE

                   QUIT 

 +7        IF 'SETPC

               QUIT 

 +8        SET $PIECE(^BWDIAG(RESIEN,0),U,SETPC)=$ORDER(^BWPN("B","HPV SCREEN",0))

 +9        QUIT 

 +10      ; Add procedures to new code

ADDPRCS(BWDXPRCS,BWDX0) ;

 +1        NEW J,PC,BWPRC,DONE

 +2        SET BWPRC=""

 +3        FOR J=1:1:17

               Begin DoDot:1

 +4                SET BWPRC=$PIECE(BWDXPRCS,",",J)

                   IF BWPRC=""

                       QUIT 

 +5                SET BWPRCIEN=$ORDER(^BWPN("B",BWPRC,0))

 +6                SET $PIECE(BWDX0,U,J)=BWPRCIEN

               End DoDot:1

               IF BWPRC=""

                   QUIT 

 +7       ; find the first blank entry and add IEN for VAGINAL ULTRASOUND

 +8        SET DONE=0

 +9        FOR K=1:1:17

               Begin DoDot:1

 +10      ; If this is already part of the BU result set, quit.

 +11               IF $PIECE(BWDX0,U,K)=$ORDER(^BWPN("B","BREAST ULTRASOUND",0))

                       SET DONE=1

                       QUIT 

 +12               IF $PIECE(BWDX0,U,K)

                       QUIT 

 +13               SET $PIECE(BWDX0,U,K)=$ORDER(^BWPN("B","BREAST ULTRASOUND",0))

                   SET DONE=1

               End DoDot:1

               IF DONE

                   QUIT 

 +14       QUIT 

 +15      ; Remove procedure from old code

REMPRCS(BWDXPRCS,BWUIEN) ;

 +1        NEW I,ARY,BWPRC,BWPRCIEN,A,TARY,PIECE,ITEM,LOOP

 +2       ; build array of items to be removed

 +3        FOR A=1:1:17

               Begin DoDot:1

 +4                SET BWPRC=$PIECE(BWDXPRCS,",",A)

                   IF BWPRC=""

                       QUIT 

 +5                SET BWPRCIEN=$ORDER(^BWPN("B",BWPRC,0))

 +6                SET TARY(BWPRCIEN)=""

               End DoDot:1

               IF BWPRC=""

                   QUIT 

 +7       ; build array of items currently defined for the result/diagnosis and remove all items from this result/diagnosis

 +8        FOR I=3:1:19

               Begin DoDot:1

 +9                SET VAL=$PIECE(^BWDIAG(BWUIEN,0),U,I)

                   IF 'VAL

                       QUIT 

 +10               SET ARY(I)=VAL

                   SET $PIECE(^BWDIAG(BWUIEN,0),U,I)=""

                   SET DIK="^BWDIAG("

                   SET DA=BWUIEN

                   DO IX2^DIK

                   QUIT 

               End DoDot:1

 +11      ; put the diagnosis items back in, but if the ARY contains one of the values in TARY, skip it, as this is to be removed.

 +12       SET PIECE=3

 +13       SET LOOP=0

           FOR 

               SET LOOP=$ORDER(ARY(LOOP))

               IF 'LOOP

                   QUIT 

               Begin DoDot:1

 +14               SET ITEM=$GET(ARY(LOOP))

 +15               IF $DATA(TARY(ITEM))

                       QUIT 

 +16               SET $PIECE(^BWDIAG(BWUIEN,0),U,PIECE)=$GET(ARY(LOOP))

 +17               SET PIECE=PIECE+1

               End DoDot:1

 +18       QUIT 

DIAG      ;

 +1       ;;BI-RADS 0-Add Imag Eval Needed::MAMMOGRAM DX BILAT,MAMMOGRAM DX UNILAT,MAMMOGRAM SCREENING:6:13

 +2       ;;BI-RADS 1:Negative:MAMMOGRAM DX BILAT,MAMMOGRAM DX UNILAT,MAMMOGRAM SCREENING

 +3       ;;BI-RADS 2:Benign Finding, Negative:MAMMOGRAM DX BILAT,MAMMOGRAM DX UNILAT,MAMMOGRAM SCREENING

 +4       ;;BI-RADS 3:Prbly Benign, Short Int F/U:MAMMOGRAM DX BILAT,MAMMOGRAM DX UNILAT,MAMMOGRAM SCREENING

 +5       ;;BI-RADS 4:Suspicious Abnorm, Consider Bx:MAMMOGRAM DX BILAT,MAMMOGRAM DX UNILAT,MAMMOGRAM SCREENING

 +6       ;;BI-RADS 5:Highly Sug of Malig, Tk Action:MAMMOGRAM DX BILAT,MAMMOGRAM DX UNILAT,MAMMOGRAM SCREENING

 +7       ;;BI-RADS 0-Prev Films Req:Incomplete, Previous Films Req:MAMMOGRAM DX BILAT,MAMMOGRAM DX UNILAT,MAMMOGRAM SCREENING:7

 +8        QUIT 

HPV       ;

 +1       ;;Positive:1:10

 +2       ;;Negative:2:20

 +3       ;;Test Not Done:3:30

 +4       ;;Unknown:9:90

 +5        QUIT