BRAWH.m

BRAWH ; IHS/ITSC/PDW,CLS - RADIOLOGY WOMEN'S HEALTH LINK ; 20 Apr 2011  7:23 PM

 ;;5.0;Radiology/Nuclear Medicine;**1002,1003**;Nov 01, 2010;Build 3

 ;;  RA*5.0*1002 IHS/OIT/CLS modified to accomodate 2007 mammogram CPT's

 ;;  

 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *

 ;;  CREATE MAMMOGRAM PROCEDURE IN WOMEN'S HEALTH FOR THIS PATIENT.

 ;;  CALLED BY ^RART WHEN A RADIOLOGY REPORT IS VERIFIED.

 ;;  CALLED BY ^RARTE1 WHEN A RADIOLOGY REPORT IS UNVERIFIED.

 ;;  CALLED BY ^BRAEXPT WHEN EXPORTING HISTORICAL MAMS TO WOMEN'S HEALTH

 ;

 ;G LOOP

 ;---> REQUIRED VARIABLES: DFN  = DFN OF RADIOLOGY PATIENT.

 ;--->                     DATE = INVERSE DATE/TIME OF VISIT.

 ;--->                     CASE = IEN OF RADIOLOGY EXAM (CASE).

 ;

 ;---> OPTIONAL VARIABLE:  RANEWP = TOTAL NEW WH PATIENTS ADDED.

 ;--->                     RAMCNT = TOTAL NEW MAMS PROCEDURES ADDED.

 ;--->                     THESE IF CALLED FROM ^BRAEXPT ROUTINE.

 ;

 ;---> GENERATED VARIBLES:

 ;---> RAPROC = IEN OF RADIOLOGY PROCEDURE (FILE #71), THEN IT

 ;--->          GETS CHANGED TO WOMEN'S HEALTH PROCEDURE TYPE

 ;--->                                   (FILE #9002086.2).

 ;---> RALOC  = WARD/CLINIC/LOCATION (FILE #44).

 ;---> RADATE = DATE OF THE PROCEDURE.

 ;---> RAPCCDT= PCC DATE/TIME IF IT EXISTS.

 ;---> RAPROV = ORDERING PROVIDER.

 ;---> RAMOD  = LEFT OR RIGHT, IF IT'S A UNILATERAL MAMMOGRAM.

 ;---> RADX   = RADIOLOGY DIAGNOSTIC CODE.

 ;---> RABWDX = WOMEN'S HEALTH RESULT/DIAGNOSIS.

 ;

CREATE(DFN,DATE,CASE) ;EP

 N RAPROC,RALOC,RADATE,RAPCCDT,RAPROV,RAMOD,RADX,RABWDX,RALEFT,RARIGHT

 ;N RACASE,RACPT,RAERR,;,RAEXAM0 ;cmn'td out IHS/HQW/SCR 10/29/01 **11**

 N RACASE,RACPT,RAERR,BRAIRAD  ;,RAEXAM0  ;IHS/HQW/SCR 10/29/01 **11** 

 N D,DR,DIE,DIC  ;IHS/ANMC/CLS 10/28/97

 ;

 ;---> QUIT IF RADIOLOGY DATA IS NOT DEFINED OR ="".

 Q:($G(DFN)']"")!($G(DATE)']"")!($G(CASE)']"")

 I $P($G(^DPT(DFN,0)),U,2)'="F" Q

 I $$AGE^AUPNPAT(DFN)<13 Q

 Q:'$D(^RADPT(DFN,"DT",DATE,"P",CASE,0))

 ;

 ;---> RAEXAM0=ZERO NODE OF RADIOLOGY EXAM.

 S RAEXAM0=^RADPT(DFN,"DT",DATE,"P",CASE,0)

 ;

 ;The next line identifies the Interpreting Physician for WH records

 S BRAIRAD=$P(RAEXAM0,U,15)   ;IHS/HQW/SCR 10/29/01 **11**

 ;

 S RACPTI=$P(^RAMIS(71,$P(RAEXAM0,U,2),0),U,9)

 S RACPT=$$GET1^DIQ(81,RACPTI,.01)

 ;

 ;IHS/BJI/DAY - Patch 1003 - Add new G codes for Digital Mammos

 Q:(RACPT'=77055)&(RACPT'=77056)&(RACPT'=77057)&(RACPT'=77031)&(RACPT'=76645)&(RACPT'="G0202")&(RACPT'="G0204")&(RACPT'="G0206")

 ;End patch

 ;

 ;

 ;---> QUIT IF NO WOMEN'S HEALTH SITE PARAMETER FILE ON THIS MACHINE.

 Q:'$D(^BWSITE(DUZ(2)))

 ;

 ;---> QUIT IF "IMPORT MAMMOGRAMS FROM RADIOLOGY" IS NOT SET TO "YES"

 ;---> IN THE WOMEN'S HEALTH SITE PARAMETERS.

 N Y S Y=^BWSITE(DUZ(2),0)

 Q:'$P(Y,U,10)

 ;

 ;---> SET BRASTAT =THE STATUS (OPEN OR CLOSED) IN WOMEN'S HEALTH.

 ;---> THAT MAMMOGRAMS SHOULD RECEIVE WHEN COPIED OVER FROM RADIOLOGY.

 S BRASTAT=$P(Y,U,23) S:BRASTAT="" BRASTAT="o"

 ;

 ;---> BELOW ARE IENS FOR BW PROCEDURE TYPE FILE #9002086.2.

 ;---> IEN 26 IN ^BWPN( IS UNILATERAL MAMMOGRAM.

 ;---> IEN 25 IN ^BWPN( IS BILATERAL MAMMOGRAM.

 ;---> IEN 28 IN ^BWPN( IS SCREENING MAMMOGRAM.

 ;---> IEN 35 IN ^BWPN( IS STERIOTACTIC BIOPSY

 ;---> IEN 38 IN ^BWPN( IS BREAST ULTRASOUND

 ;

 I RACPT=76090 S RAPROC=26 D COPY(RAEXAM0) G EXIT

 I RACPT=76091 S RAPROC=25 D COPY(RAEXAM0) G EXIT

 I RACPT=76092 S RAPROC=28 D COPY(RAEXAM0) G EXIT

 I RACPT=76095 S RAPROC=35 D COPY(RAEXAM0) G EXIT  ;IHS/ANMC/MWR

 I RACPT=76645 S RAPROC=38 D COPY(RAEXAM0) G EXIT  ;IHS/ANMC/MWR

 ;

 ;----> ADDED 2007 CPT CODES

 I RACPT=77055 S RAPROC=26 D COPY(RAEXAM0) G EXIT  ;IHS/OIT/CLS patch 1002

 I RACPT=77056 S RAPROC=25 D COPY(RAEXAM0) G EXIT  ;IHS/OIT/CLS patch 1002

 I RACPT=77057 S RAPROC=28 D COPY(RAEXAM0) G EXIT  ;IHS/OIT/CLS patch 1002

 I RACPT=77031 S RAPROC=35 D COPY(RAEXAM0) G EXIT  ;IHS/ANMC/MWR  ;IHS/OIT/CLS patch 1002

 I RACPT=76645 S RAPROC=38 D COPY(RAEXAM0) G EXIT  ;IHS/ANMC/MWR

 ;

 ;IHS/BJI/DAY - Patch 1003 - Add new G codes for Digital Mammos

 I RACPT="G0202" S RAPROC=28 D COPY(RAEXAM0) G EXIT

 I RACPT="G0204" S RAPROC=25 D COPY(RAEXAM0) G EXIT

 I RACPT="G0206" S RAPROC=26 D COPY(RAEXAM0) G EXIT

 ;End patch

 ;

EXIT ;EP

 K I,N,X

 Q

 ;

 ;

COPY(Y) ;EP

 ;---> COPY MAM PROCEDURE DATA FROM RADIOLOGY TO WOMEN'S HEALTH.

 ;---> VARIABLE DFN=PATIENT

 ;---> LOCATION=DUZ(2)

 ;---> WARD/CLINIC/LOCATION

 N X

 S RALOC=$P(Y,U,8)

 ;

 ;---> RADATE=DATE OF THE PROCEDURE.

 S RADATE=$P($P(^RADPT(DFN,"DT",DATE,0),U),".")

 ;

 ;---> RECONSTRUCT THE FULL CASE# FOR THIS RAD PROCEDURE.

 ;---> THIS IS USED AS A LINK (XREF) BETWEEN THE RADIOLOGY PROCEDURE

 ;---> AND THE WOMEN'S HEALTH PROCEDURE.

 S RACASE=$E(RADATE,4,7)_$E(RADATE,2,3)_"-"_$P(Y,U)

 ;---> CHECK TO BE SURE THE CASE# XREF IS REALLY DOWN THERE.

 S:'$D(^RADPT("ADC",RACASE,DFN,DATE,CASE)) RACASE="UNKNOWN"

 ;

 ;---> QUIT IF THIS PROCEDURE HAS ALREADY BEEN SENT TO WOMEN'S HEALTH.

 I $D(^BWPCD("E",RACASE)) Q

 ;

 ;---> PCC DATE/TIME; IF NO TIME, ATTACH 12 NOON.

 I $D(^RADPT(DFN,"DT",DATE,"P",CASE,"PCC")) D

 .S RAPCCDT=$P(^RADPT(DFN,"DT",DATE,"P",CASE,"PCC"),U)

 .S:'$P(RAPCCDT,".",2) RAPCCDT=RAPCCDT_".12"

 ;

 ;

 ;---> REQUESTING PROVIDER/ORDERING PROVIDER

 ;---> USE FILE 16 "A3" POINTER TO PASS PROVIDER FILE #200 IEN.

 ;---> CHANGE THIS WHEN RADIOLOGY CONVERSION TO FILE #200 IS DONE.

 ;S RAPROV=^DIC(16,$P(Y,U,14),"A3") ;IHS/ISD/EDE 02/16/97

 ; chg file 16 to 200  IHS/ISD/EDE 02/16/97

 S RAPROV=$P(Y,U,14) ;IHS/ISD/EDE 02/16/97

 ;

 ;---> IF UNILATERAL, ATTEMPT TO PICK UP LEFT OR RIGHT MODIFIER.

 I RAPROC=26 D

 .I $D(^RADPT(DFN,"DT",DATE,"P",CASE,"M",0)) D

 ..N N S N=0

 ..F  S N=$O(^RADPT(DFN,"DT",DATE,"P",CASE,"M",N)) Q:'N  D

 ...S RAMOD=$P(^RADPT(DFN,"DT",DATE,"P",CASE,"M",N,0),U)

 ...S RAMOD=$P(^RAMIS(71.2,RAMOD,0),U)

 ...I "LEFTleft"[RAMOD S RALEFT=1

 ...I "RIGHTright"[RAMOD S RARIGHT=1

 ..Q:$D(RALEFT)&($D(RARIGHT))

 ..I $D(RALEFT) S RAMOD="l" Q

 ..I $D(RARIGHT) S RAMOD="r" Q

 ;

 ;---> IF THERE'S A DIAGNOSTIC CODE, ATTEMPT TO PICK UP DIAGNOSIS.

 ;---> USE "BW DIAGNOSTIC CODE TRANSLATION" FILE #9002086.32.

 S RADX=$P(Y,U,13)

 I +RADX I $D(^BWRADX("C",RADX)) S RABWDX=$O(^BWRADX("C",RADX,0))

 ;

 W !!?20,"* Updating Women's Health Database. *",!

 ;

PATIENT ;---> IF PATIENT ISN'T IN WOMEN'S HEALTH DATABASE, ADD HER.

 S RAERR=1

 I '$D(^BWP(DFN,0)) D

 .D AUTOADD^BWPATE(DFN,DUZ(2),.RAERR)

 .I $D(RANEWP) S:RAERR RANEWP=RANEWP+1

 Q:RAERR<0

 ;

PROC ;---> CREATE MAMMOGRAM PROCEDURE IN BW PROCEDURE FILE #9002086.1.

 ;

 S RADR=".02////"_DFN_";.03////"_$G(RAPCCDT)_";.04////"_RAPROC

 S RADR=RADR_";.05////"_$G(RABWDX)_";.07////"_RAPROV

 S RADR=RADR_";.09////"_$G(RAMOD)_";.1////"_DUZ(2)_";.11////"_RALOC

 S RADR=RADR_";.12////"_RADATE_";.14////"_BRASTAT_";.15////"_RACASE

 ;

 ;S RADR=RADR_";.18////.5;.19////"_DT  ;Cmnt'd out to add Interpreting Radiologist field IHS/HQW/SCR 10/29/01 **11**

 S RADR=RADR_";.18////.5;.19////"_DT_";.35////"_BRAIRAD  ;IHS/HQW/SCR 10/29/01 **11**

 ;

 D NEW2^BWPROC(DFN,RAPROC,RADATE,RADR,"","",.RAERR)

 I $D(RAMCNT) S:RAERR>-1 RAMCNT=RAMCNT+1

 Q

 ;

 ;

UPDATE(DFN,DATE,CASE) ;EP

 ;---> MODIFY WOMEN'S HEALTH PROCEDURE TO REFLECT CHANGE.

 ;---> CALLED FROM RARTE1 (DELETE A REPORT AND UNVERIFY A REPORT).

 ; maybe called by RAEDFN if the system is setup to send PCC date at EXAMINED

 ;

 ;

 ;Q:'$D(DFN)!('$D(DATE))!('$D(CASE))

 Q:'$G(DFN)!('$G(DATE))!('$G(CASE))  ;IHS/ITSC/CLS 12/31/2003

 Q:'$D(^RADPT(DFN,"DT",DATE,"P",CASE,0))

 I $P($G(^DPT(DFN,0)),U,2)'="F" Q

 I $$AGE^AUPNPAT(DFN)<13 Q

 ;

 W !!,?20,"* Updating Women's Health Database *",!

 ;

 N RAIEN,RADATE,RACASE,RAMSG

 ;

 ;---> RADATE=DATE OF PROCEDURE.

 S RADATE=$P($P(^RADPT(DFN,"DT",DATE,0),U),".")

 S RACASE=$P(^RADPT(DFN,"DT",DATE,"P",CASE,0),U)

 ;

 ;---> RACASE=RECONSTRUCTED CASE# OF PROCEDURE.

 S RACASE=$E(RADATE,4,7)_$E(RADATE,2,3)_"-"_RACASE

 ;---> QUIT IF NO CASE# XREF IN WOMEN'S HEALTH PROCEDURE FILE.

 Q:'$D(^BWPCD("E",RACASE))

 ;

 S RAIEN=$O(^BWPCD("E",RACASE,0))

 Q:'$D(^BWPCD(RAIEN,0))

 S RAMSG="* NOTE: THIS PROCEDURE HAS BEEN ALTERED IN RADIOLOGY.  "

 S RAMSG=RAMSG_"FOLLOW-UP REQUIRED!!  RADIOLOGY CASE# IS "_RACASE_"."

 ;---> IF THERE'S AN EXISTING CLINICAL HX, PRESERVE AND CONCATENATE IT

 ;---> TO THE END OF THE MESSAGE PASSED HERE.

 I $G(^BWPCD(RAIEN,3))]"" D

 .S RAMSG=RAMSG_"  PREVIOUS CLINICAL HX: "

 .S RAMSG=RAMSG_^BWPCD(RAIEN,3),RAMSG=$E(RAMSG,1,240)

 D RADMOD^BWPROC(RAIEN,RAMSG)

 Q

 ;

 ;

UPDTDX(DFN,DATE,CASE) ;EP - Called from BRAPRAD when report is filed

 ;

 N RAZERO,RACASE,RADATE,RAACC,RADA

 N RADX,RAIRAD,RABWDX,DA,DR

 I '$G(DFN) Q

 I '$G(DATE) Q

 I '$G(CASE) Q

 I '$D(^RADPT(DFN,"DT",DATE,"P",CASE,0)) Q

 I $P($G(^DPT(DFN,0)),U,2)'="F" Q

 I $$AGE^AUPNPAT(DFN)<13 Q

 ;

 ;Check WH Site Parameter to see if we pass data

 I $$GET1^DIQ(9002086.02,DUZ(2),.1,"I")'=1 Q

 ;

 ;Build Accession Number

 S RAZERO=$G(^RADPT(DFN,"DT",DATE,"P",CASE,0))

 I RAZERO="" Q

 S RACASE=$P(RAZERO,U)

 S RADATE=$P($P(^RADPT(DFN,"DT",DATE,0),U),".")

 S RAACC=$E(RADATE,4,7)_$E(RADATE,2,3)_"-"_RACASE

 ;

 ;If BW Procedure does not exist then Create it and quit

 S RADA=$O(^BWPCD("E",RAACC,0))

 I RADA="" D CREATE^BRAWH(DFN,DATE,CASE) Q

 ;

 ;Get DX

 S RADX=$P(RAZERO,U,13)

 I +RADX D

 .S RABWDX=$O(^BWRADX("C",RADX,0))

 .I RABWDX="" Q

 .;

 .;File in Women's Health BW PROCEDURE file

 .S DA=RADA

 .S DR=".05////"_RABWDX

 .D DIE^BWFMAN(9002086.1,DR,DA)

 ;

 ;Get Interpreting Radiologist

 S RAIRAD=$P(RAZERO,U,15)

 I +RAIRAD D

 .;

 .;File in Women's Health BW PROCEDURE file

 .S DA=RADA

 .S DR=".35////"_RAIRAD

 .D DIE^BWFMAN(9002086.1,DR,DA)

 ;

 Q

 ;

LOOP ;EP

 ;---> LOOP THROUGH PREVIOUS RA EXAMS AND PASS TO WOMEN'S HEALTH.

 ;

 ;---> QUIT IF NO WOMEN'S HEALTH SITE PARAMETER FILE ON THIS MACHINE.

 Q:'$D(^BWSITE(DUZ(2)))

 ;

 ;---> QUIT IF "IMPORT MAMMOGRAMS FROM RADIOLOGY" IS NOT SET TO "YES"

 ;---> IN THE WOMEN'S HEALTH SITE PARAMETERS.

 Q:'$P(^BWSITE(DUZ(2),0),U,10)

 ;

 N BRADT1,BRACOUNT,BRADFN,BRADT2,BRACS,BRA0,DIR,X,Y

 D GETDATE  ;IHS/OIT/CLS patch 1002 ask date S BRADT1 

 S BRACOUNT=0

 F  S BRADT1=$O(^RADPT("AR",BRADT1)) Q:'BRADT1  D

 .S BRADFN=0

 .F  S BRADFN=$O(^RADPT("AR",BRADT1,BRADFN)) Q:'BRADFN  D

 ..S BRADT2=0

 ..F  S BRADT2=$O(^RADPT("AR",BRADT1,BRADFN,BRADT2)) Q:'BRADT2  D

 ...Q:'$D(^RADPT(BRADFN,"DT",BRADT2))

 ...S BRACS=0

 ...F  S BRACS=$O(^RADPT(BRADFN,"DT",BRADT2,"P",BRACS)) Q:'BRACS  D

 ....Q:'$D(^RADPT(BRADFN,"DT",BRADT2,"P",BRACS,0))

 ....S BRA0=^RADPT(BRADFN,"DT",BRADT2,"P",BRACS,0)

 ....;---> QUIT IF THIS EXAM DOES NOT HAVE A STATUS OF COMPLETE.

 ....;Q:$P(BRA0,U,3)'=2

 ....;W !,^RADPT(BRADFN,"DT",BRADT2,"P",BRACS,0)

 ....D CREATE(BRADFN,BRADT2,BRACS)

 ....S BRACOUNT=BRACOUNT+1

 W !?5,BRACOUNT," procedures checked."

 Q

 ;

GETDATE ;---> GET STARTDATE FOR LOOP

 S DIR(0)="D^:"_DT_":AE"

 S DIR("A")="Enter starting date"

 S DIR("?")="Enter date to begin searching from"

 D ^DIR

 Q:$D(DIRUT)

 S BRADT1=Y

 Q

BRAWH     ; IHS/ITSC/PDW,CLS - RADIOLOGY WOMEN'S HEALTH LINK ; 20 Apr 2011  7:23 PM

 +1       ;;5.0;Radiology/Nuclear Medicine;**1002,1003**;Nov 01, 2010;Build 3

 +2       ;;  RA*5.0*1002 IHS/OIT/CLS modified to accomodate 2007 mammogram CPT's

 +3       ;;  

 +4       ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *

 +5       ;;  CREATE MAMMOGRAM PROCEDURE IN WOMEN'S HEALTH FOR THIS PATIENT.

 +6       ;;  CALLED BY ^RART WHEN A RADIOLOGY REPORT IS VERIFIED.

 +7       ;;  CALLED BY ^RARTE1 WHEN A RADIOLOGY REPORT IS UNVERIFIED.

 +8       ;;  CALLED BY ^BRAEXPT WHEN EXPORTING HISTORICAL MAMS TO WOMEN'S HEALTH

 +9       ;

 +10      ;G LOOP

 +11      ;---> REQUIRED VARIABLES: DFN  = DFN OF RADIOLOGY PATIENT.

 +12      ;--->                     DATE = INVERSE DATE/TIME OF VISIT.

 +13      ;--->                     CASE = IEN OF RADIOLOGY EXAM (CASE).

 +14      ;

 +15      ;---> OPTIONAL VARIABLE:  RANEWP = TOTAL NEW WH PATIENTS ADDED.

 +16      ;--->                     RAMCNT = TOTAL NEW MAMS PROCEDURES ADDED.

 +17      ;--->                     THESE IF CALLED FROM ^BRAEXPT ROUTINE.

 +18      ;

 +19      ;---> GENERATED VARIBLES:

 +20      ;---> RAPROC = IEN OF RADIOLOGY PROCEDURE (FILE #71), THEN IT

 +21      ;--->          GETS CHANGED TO WOMEN'S HEALTH PROCEDURE TYPE

 +22      ;--->                                   (FILE #9002086.2).

 +23      ;---> RALOC  = WARD/CLINIC/LOCATION (FILE #44).

 +24      ;---> RADATE = DATE OF THE PROCEDURE.

 +25      ;---> RAPCCDT= PCC DATE/TIME IF IT EXISTS.

 +26      ;---> RAPROV = ORDERING PROVIDER.

 +27      ;---> RAMOD  = LEFT OR RIGHT, IF IT'S A UNILATERAL MAMMOGRAM.

 +28      ;---> RADX   = RADIOLOGY DIAGNOSTIC CODE.

 +29      ;---> RABWDX = WOMEN'S HEALTH RESULT/DIAGNOSIS.

 +30      ;

CREATE(DFN,DATE,CASE) ;EP

 +1        NEW RAPROC,RALOC,RADATE,RAPCCDT,RAPROV,RAMOD,RADX,RABWDX,RALEFT,RARIGHT

 +2       ;N RACASE,RACPT,RAERR,;,RAEXAM0 ;cmn'td out IHS/HQW/SCR 10/29/01 **11**

 +3       ;,RAEXAM0  ;IHS/HQW/SCR 10/29/01 **11** 

           NEW RACASE,RACPT,RAERR,BRAIRAD

 +4       ;IHS/ANMC/CLS 10/28/97

           NEW D,DR,DIE,DIC

 +5       ;

 +6       ;---> QUIT IF RADIOLOGY DATA IS NOT DEFINED OR ="".

 +7        IF ($GET(DFN)']"")!($GET(DATE)']"")!($GET(CASE)']"")

               QUIT 

 +8        IF $PIECE($GET(^DPT(DFN,0)),U,2)'="F"

               QUIT 

 +9        IF $$AGE^AUPNPAT(DFN)<13

               QUIT 

 +10       IF '$DATA(^RADPT(DFN,"DT",DATE,"P",CASE,0))

               QUIT 

 +11      ;

 +12      ;---> RAEXAM0=ZERO NODE OF RADIOLOGY EXAM.

 +13       SET RAEXAM0=^RADPT(DFN,"DT",DATE,"P",CASE,0)

 +14      ;

 +15      ;The next line identifies the Interpreting Physician for WH records

 +16      ;IHS/HQW/SCR 10/29/01 **11**

           SET BRAIRAD=$PIECE(RAEXAM0,U,15)

 +17      ;

 +18       SET RACPTI=$PIECE(^RAMIS(71,$PIECE(RAEXAM0,U,2),0),U,9)

 +19       SET RACPT=$$GET1^DIQ(81,RACPTI,.01)

 +20      ;

 +21      ;IHS/BJI/DAY - Patch 1003 - Add new G codes for Digital Mammos

 +22       IF (RACPT'=77055)&(RACPT'=77056)&(RACPT'=77057)&(RACPT'=77031)&(RACPT'=76645)&(RACPT'="G0202")&(RACPT'="G0204")&(RACPT'="G0206")

               QUIT 

 +23      ;End patch

 +24      ;

 +25      ;

 +26      ;---> QUIT IF NO WOMEN'S HEALTH SITE PARAMETER FILE ON THIS MACHINE.

 +27       IF '$DATA(^BWSITE(DUZ(2)))

               QUIT 

 +28      ;

 +29      ;---> QUIT IF "IMPORT MAMMOGRAMS FROM RADIOLOGY" IS NOT SET TO "YES"

 +30      ;---> IN THE WOMEN'S HEALTH SITE PARAMETERS.

 +31       NEW Y

           SET Y=^BWSITE(DUZ(2),0)

 +32       IF '$PIECE(Y,U,10)

               QUIT 

 +33      ;

 +34      ;---> SET BRASTAT =THE STATUS (OPEN OR CLOSED) IN WOMEN'S HEALTH.

 +35      ;---> THAT MAMMOGRAMS SHOULD RECEIVE WHEN COPIED OVER FROM RADIOLOGY.

 +36       SET BRASTAT=$PIECE(Y,U,23)

           IF BRASTAT=""

               SET BRASTAT="o"

 +37      ;

 +38      ;---> BELOW ARE IENS FOR BW PROCEDURE TYPE FILE #9002086.2.

 +39      ;---> IEN 26 IN ^BWPN( IS UNILATERAL MAMMOGRAM.

 +40      ;---> IEN 25 IN ^BWPN( IS BILATERAL MAMMOGRAM.

 +41      ;---> IEN 28 IN ^BWPN( IS SCREENING MAMMOGRAM.

 +42      ;---> IEN 35 IN ^BWPN( IS STERIOTACTIC BIOPSY

 +43      ;---> IEN 38 IN ^BWPN( IS BREAST ULTRASOUND

 +44      ;

 +45       IF RACPT=76090

               SET RAPROC=26

               DO COPY(RAEXAM0)

               GOTO EXIT

 +46       IF RACPT=76091

               SET RAPROC=25

               DO COPY(RAEXAM0)

               GOTO EXIT

 +47       IF RACPT=76092

               SET RAPROC=28

               DO COPY(RAEXAM0)

               GOTO EXIT

 +48      ;IHS/ANMC/MWR

           IF RACPT=76095

               SET RAPROC=35

               DO COPY(RAEXAM0)

               GOTO EXIT

 +49      ;IHS/ANMC/MWR

           IF RACPT=76645

               SET RAPROC=38

               DO COPY(RAEXAM0)

               GOTO EXIT

 +50      ;

 +51      ;----> ADDED 2007 CPT CODES

 +52      ;IHS/OIT/CLS patch 1002

           IF RACPT=77055

               SET RAPROC=26

               DO COPY(RAEXAM0)

               GOTO EXIT

 +53      ;IHS/OIT/CLS patch 1002

           IF RACPT=77056

               SET RAPROC=25

               DO COPY(RAEXAM0)

               GOTO EXIT

 +54      ;IHS/OIT/CLS patch 1002

           IF RACPT=77057

               SET RAPROC=28

               DO COPY(RAEXAM0)

               GOTO EXIT

 +55      ;IHS/ANMC/MWR  ;IHS/OIT/CLS patch 1002

           IF RACPT=77031

               SET RAPROC=35

               DO COPY(RAEXAM0)

               GOTO EXIT

 +56      ;IHS/ANMC/MWR

           IF RACPT=76645

               SET RAPROC=38

               DO COPY(RAEXAM0)

               GOTO EXIT

 +57      ;

 +58      ;IHS/BJI/DAY - Patch 1003 - Add new G codes for Digital Mammos

 +59       IF RACPT="G0202"

               SET RAPROC=28

               DO COPY(RAEXAM0)

               GOTO EXIT

 +60       IF RACPT="G0204"

               SET RAPROC=25

               DO COPY(RAEXAM0)

               GOTO EXIT

 +61       IF RACPT="G0206"

               SET RAPROC=26

               DO COPY(RAEXAM0)

               GOTO EXIT

 +62      ;End patch

 +63      ;

EXIT      ;EP

 +1        KILL I,N,X

 +2        QUIT 

 +3       ;

 +4       ;

COPY(Y)   ;EP

 +1       ;---> COPY MAM PROCEDURE DATA FROM RADIOLOGY TO WOMEN'S HEALTH.

 +2       ;---> VARIABLE DFN=PATIENT

 +3       ;---> LOCATION=DUZ(2)

 +4       ;---> WARD/CLINIC/LOCATION

 +5        NEW X

 +6        SET RALOC=$PIECE(Y,U,8)

 +7       ;

 +8       ;---> RADATE=DATE OF THE PROCEDURE.

 +9        SET RADATE=$PIECE($PIECE(^RADPT(DFN,"DT",DATE,0),U),".")

 +10      ;

 +11      ;---> RECONSTRUCT THE FULL CASE# FOR THIS RAD PROCEDURE.

 +12      ;---> THIS IS USED AS A LINK (XREF) BETWEEN THE RADIOLOGY PROCEDURE

 +13      ;---> AND THE WOMEN'S HEALTH PROCEDURE.

 +14       SET RACASE=$EXTRACT(RADATE,4,7)_$EXTRACT(RADATE,2,3)_"-"_$PIECE(Y,U)

 +15      ;---> CHECK TO BE SURE THE CASE# XREF IS REALLY DOWN THERE.

 +16       IF '$DATA(^RADPT("ADC",RACASE,DFN,DATE,CASE))

               SET RACASE="UNKNOWN"

 +17      ;

 +18      ;---> QUIT IF THIS PROCEDURE HAS ALREADY BEEN SENT TO WOMEN'S HEALTH.

 +19       IF $DATA(^BWPCD("E",RACASE))

               QUIT 

 +20      ;

 +21      ;---> PCC DATE/TIME; IF NO TIME, ATTACH 12 NOON.

 +22       IF $DATA(^RADPT(DFN,"DT",DATE,"P",CASE,"PCC"))

               Begin DoDot:1

 +23               SET RAPCCDT=$PIECE(^RADPT(DFN,"DT",DATE,"P",CASE,"PCC"),U)

 +24               IF '$PIECE(RAPCCDT,".",2)

                       SET RAPCCDT=RAPCCDT_".12"

               End DoDot:1

 +25      ;

 +26      ;

 +27      ;---> REQUESTING PROVIDER/ORDERING PROVIDER

 +28      ;---> USE FILE 16 "A3" POINTER TO PASS PROVIDER FILE #200 IEN.

 +29      ;---> CHANGE THIS WHEN RADIOLOGY CONVERSION TO FILE #200 IS DONE.

 +30      ;S RAPROV=^DIC(16,$P(Y,U,14),"A3") ;IHS/ISD/EDE 02/16/97

 +31      ; chg file 16 to 200  IHS/ISD/EDE 02/16/97

 +32      ;IHS/ISD/EDE 02/16/97

           SET RAPROV=$PIECE(Y,U,14)

 +33      ;

 +34      ;---> IF UNILATERAL, ATTEMPT TO PICK UP LEFT OR RIGHT MODIFIER.

 +35       IF RAPROC=26

               Begin DoDot:1

 +36               IF $DATA(^RADPT(DFN,"DT",DATE,"P",CASE,"M",0))

                       Begin DoDot:2

 +37                       NEW N

                           SET N=0

 +38                       FOR 

                               SET N=$ORDER(^RADPT(DFN,"DT",DATE,"P",CASE,"M",N))

                               IF 'N

                                   QUIT 

                               Begin DoDot:3

 +39                               SET RAMOD=$PIECE(^RADPT(DFN,"DT",DATE,"P",CASE,"M",N,0),U)

 +40                               SET RAMOD=$PIECE(^RAMIS(71.2,RAMOD,0),U)

 +41                               IF "LEFTleft"[RAMOD

                                       SET RALEFT=1

 +42                               IF "RIGHTright"[RAMOD

                                       SET RARIGHT=1

                               End DoDot:3

 +43                       IF $DATA(RALEFT)&($DATA(RARIGHT))

                               QUIT 

 +44                       IF $DATA(RALEFT)

                               SET RAMOD="l"

                               QUIT 

 +45                       IF $DATA(RARIGHT)

                               SET RAMOD="r"

                               QUIT 

                       End DoDot:2

               End DoDot:1

 +46      ;

 +47      ;---> IF THERE'S A DIAGNOSTIC CODE, ATTEMPT TO PICK UP DIAGNOSIS.

 +48      ;---> USE "BW DIAGNOSTIC CODE TRANSLATION" FILE #9002086.32.

 +49       SET RADX=$PIECE(Y,U,13)

 +50       IF +RADX

               IF $DATA(^BWRADX("C",RADX))

                   SET RABWDX=$ORDER(^BWRADX("C",RADX,0))

 +51      ;

 +52       WRITE !!?20,"* Updating Women's Health Database. *",!

 +53      ;

PATIENT   ;---> IF PATIENT ISN'T IN WOMEN'S HEALTH DATABASE, ADD HER.

 +1        SET RAERR=1

 +2        IF '$DATA(^BWP(DFN,0))

               Begin DoDot:1

 +3                DO AUTOADD^BWPATE(DFN,DUZ(2),.RAERR)

 +4                IF $DATA(RANEWP)

                       IF RAERR

                           SET RANEWP=RANEWP+1

               End DoDot:1

 +5        IF RAERR<0

               QUIT 

 +6       ;

PROC      ;---> CREATE MAMMOGRAM PROCEDURE IN BW PROCEDURE FILE #9002086.1.

 +1       ;

 +2        SET RADR=".02////"_DFN_";.03////"_$GET(RAPCCDT)_";.04////"_RAPROC

 +3        SET RADR=RADR_";.05////"_$GET(RABWDX)_";.07////"_RAPROV

 +4        SET RADR=RADR_";.09////"_$GET(RAMOD)_";.1////"_DUZ(2)_";.11////"_RALOC

 +5        SET RADR=RADR_";.12////"_RADATE_";.14////"_BRASTAT_";.15////"_RACASE

 +6       ;

 +7       ;S RADR=RADR_";.18////.5;.19////"_DT  ;Cmnt'd out to add Interpreting Radiologist field IHS/HQW/SCR 10/29/01 **11**

 +8       ;IHS/HQW/SCR 10/29/01 **11**

           SET RADR=RADR_";.18////.5;.19////"_DT_";.35////"_BRAIRAD

 +9       ;

 +10       DO NEW2^BWPROC(DFN,RAPROC,RADATE,RADR,"","",.RAERR)

 +11       IF $DATA(RAMCNT)

               IF RAERR>-1

                   SET RAMCNT=RAMCNT+1

 +12       QUIT 

 +13      ;

 +14      ;

UPDATE(DFN,DATE,CASE) ;EP

 +1       ;---> MODIFY WOMEN'S HEALTH PROCEDURE TO REFLECT CHANGE.

 +2       ;---> CALLED FROM RARTE1 (DELETE A REPORT AND UNVERIFY A REPORT).

 +3       ; maybe called by RAEDFN if the system is setup to send PCC date at EXAMINED

 +4       ;

 +5       ;

 +6       ;Q:'$D(DFN)!('$D(DATE))!('$D(CASE))

 +7       ;IHS/ITSC/CLS 12/31/2003

           IF '$GET(DFN)!('$GET(DATE))!('$GET(CASE))

               QUIT 

 +8        IF '$DATA(^RADPT(DFN,"DT",DATE,"P",CASE,0))

               QUIT 

 +9        IF $PIECE($GET(^DPT(DFN,0)),U,2)'="F"

               QUIT 

 +10       IF $$AGE^AUPNPAT(DFN)<13

               QUIT 

 +11      ;

 +12       WRITE !!,?20,"* Updating Women's Health Database *",!

 +13      ;

 +14       NEW RAIEN,RADATE,RACASE,RAMSG

 +15      ;

 +16      ;---> RADATE=DATE OF PROCEDURE.

 +17       SET RADATE=$PIECE($PIECE(^RADPT(DFN,"DT",DATE,0),U),".")

 +18       SET RACASE=$PIECE(^RADPT(DFN,"DT",DATE,"P",CASE,0),U)

 +19      ;

 +20      ;---> RACASE=RECONSTRUCTED CASE# OF PROCEDURE.

 +21       SET RACASE=$EXTRACT(RADATE,4,7)_$EXTRACT(RADATE,2,3)_"-"_RACASE

 +22      ;---> QUIT IF NO CASE# XREF IN WOMEN'S HEALTH PROCEDURE FILE.

 +23       IF '$DATA(^BWPCD("E",RACASE))

               QUIT 

 +24      ;

 +25       SET RAIEN=$ORDER(^BWPCD("E",RACASE,0))

 +26       IF '$DATA(^BWPCD(RAIEN,0))

               QUIT 

 +27       SET RAMSG="* NOTE: THIS PROCEDURE HAS BEEN ALTERED IN RADIOLOGY.  "

 +28       SET RAMSG=RAMSG_"FOLLOW-UP REQUIRED!!  RADIOLOGY CASE# IS "_RACASE_"."

 +29      ;---> IF THERE'S AN EXISTING CLINICAL HX, PRESERVE AND CONCATENATE IT

 +30      ;---> TO THE END OF THE MESSAGE PASSED HERE.

 +31       IF $GET(^BWPCD(RAIEN,3))]""

               Begin DoDot:1

 +32               SET RAMSG=RAMSG_"  PREVIOUS CLINICAL HX: "

 +33               SET RAMSG=RAMSG_^BWPCD(RAIEN,3)

                   SET RAMSG=$EXTRACT(RAMSG,1,240)

               End DoDot:1

 +34       DO RADMOD^BWPROC(RAIEN,RAMSG)

 +35       QUIT 

 +36      ;

 +37      ;

UPDTDX(DFN,DATE,CASE) ;EP - Called from BRAPRAD when report is filed

 +1       ;

 +2        NEW RAZERO,RACASE,RADATE,RAACC,RADA

 +3        NEW RADX,RAIRAD,RABWDX,DA,DR

 +4        IF '$GET(DFN)

               QUIT 

 +5        IF '$GET(DATE)

               QUIT 

 +6        IF '$GET(CASE)

               QUIT 

 +7        IF '$DATA(^RADPT(DFN,"DT",DATE,"P",CASE,0))

               QUIT 

 +8        IF $PIECE($GET(^DPT(DFN,0)),U,2)'="F"

               QUIT 

 +9        IF $$AGE^AUPNPAT(DFN)<13

               QUIT 

 +10      ;

 +11      ;Check WH Site Parameter to see if we pass data

 +12       IF $$GET1^DIQ(9002086.02,DUZ(2),.1,"I")'=1

               QUIT 

 +13      ;

 +14      ;Build Accession Number

 +15       SET RAZERO=$GET(^RADPT(DFN,"DT",DATE,"P",CASE,0))

 +16       IF RAZERO=""

               QUIT 

 +17       SET RACASE=$PIECE(RAZERO,U)

 +18       SET RADATE=$PIECE($PIECE(^RADPT(DFN,"DT",DATE,0),U),".")

 +19       SET RAACC=$EXTRACT(RADATE,4,7)_$EXTRACT(RADATE,2,3)_"-"_RACASE

 +20      ;

 +21      ;If BW Procedure does not exist then Create it and quit

 +22       SET RADA=$ORDER(^BWPCD("E",RAACC,0))

 +23       IF RADA=""

               DO CREATE^BRAWH(DFN,DATE,CASE)

               QUIT 

 +24      ;

 +25      ;Get DX

 +26       SET RADX=$PIECE(RAZERO,U,13)

 +27       IF +RADX

               Begin DoDot:1

 +28               SET RABWDX=$ORDER(^BWRADX("C",RADX,0))

 +29               IF RABWDX=""

                       QUIT 

 +30      ;

 +31      ;File in Women's Health BW PROCEDURE file

 +32               SET DA=RADA

 +33               SET DR=".05////"_RABWDX

 +34               DO DIE^BWFMAN(9002086.1,DR,DA)

               End DoDot:1

 +35      ;

 +36      ;Get Interpreting Radiologist

 +37       SET RAIRAD=$PIECE(RAZERO,U,15)

 +38       IF +RAIRAD

               Begin DoDot:1

 +39      ;

 +40      ;File in Women's Health BW PROCEDURE file

 +41               SET DA=RADA

 +42               SET DR=".35////"_RAIRAD

 +43               DO DIE^BWFMAN(9002086.1,DR,DA)

               End DoDot:1

 +44      ;

 +45       QUIT 

 +46      ;

LOOP      ;EP

 +1       ;---> LOOP THROUGH PREVIOUS RA EXAMS AND PASS TO WOMEN'S HEALTH.

 +2       ;

 +3       ;---> QUIT IF NO WOMEN'S HEALTH SITE PARAMETER FILE ON THIS MACHINE.

 +4        IF '$DATA(^BWSITE(DUZ(2)))

               QUIT 

 +5       ;

 +6       ;---> QUIT IF "IMPORT MAMMOGRAMS FROM RADIOLOGY" IS NOT SET TO "YES"

 +7       ;---> IN THE WOMEN'S HEALTH SITE PARAMETERS.

 +8        IF '$PIECE(^BWSITE(DUZ(2),0),U,10)

               QUIT 

 +9       ;

 +10       NEW BRADT1,BRACOUNT,BRADFN,BRADT2,BRACS,BRA0,DIR,X,Y

 +11      ;IHS/OIT/CLS patch 1002 ask date S BRADT1 

           DO GETDATE

 +12       SET BRACOUNT=0

 +13       FOR 

               SET BRADT1=$ORDER(^RADPT("AR",BRADT1))

               IF 'BRADT1

                   QUIT 

               Begin DoDot:1

 +14               SET BRADFN=0

 +15               FOR 

                       SET BRADFN=$ORDER(^RADPT("AR",BRADT1,BRADFN))

                       IF 'BRADFN

                           QUIT 

                       Begin DoDot:2

 +16                       SET BRADT2=0

 +17                       FOR 

                               SET BRADT2=$ORDER(^RADPT("AR",BRADT1,BRADFN,BRADT2))

                               IF 'BRADT2

                                   QUIT 

                               Begin DoDot:3

 +18                               IF '$DATA(^RADPT(BRADFN,"DT",BRADT2))

                                       QUIT 

 +19                               SET BRACS=0

 +20                               FOR 

                                       SET BRACS=$ORDER(^RADPT(BRADFN,"DT",BRADT2,"P",BRACS))

                                       IF 'BRACS

                                           QUIT 

                                       Begin DoDot:4

 +21                                       IF '$DATA(^RADPT(BRADFN,"DT",BRADT2,"P",BRACS,0))

                                               QUIT 

 +22                                       SET BRA0=^RADPT(BRADFN,"DT",BRADT2,"P",BRACS,0)

 +23      ;---> QUIT IF THIS EXAM DOES NOT HAVE A STATUS OF COMPLETE.

 +24      ;Q:$P(BRA0,U,3)'=2

 +25      ;W !,^RADPT(BRADFN,"DT",BRADT2,"P",BRACS,0)

 +26                                       DO CREATE(BRADFN,BRADT2,BRACS)

 +27                                       SET BRACOUNT=BRACOUNT+1

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +28       WRITE !?5,BRACOUNT," procedures checked."

 +29       QUIT 

 +30      ;

GETDATE   ;---> GET STARTDATE FOR LOOP

 +1        SET DIR(0)="D^:"_DT_":AE"

 +2        SET DIR("A")="Enter starting date"

 +3        SET DIR("?")="Enter date to begin searching from"

 +4        DO ^DIR

 +5        IF $DATA(DIRUT)

               QUIT 

 +6        SET BRADT1=Y

 +7        QUIT