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
