WVRALINK ;HCIOFO/FT - RAD/NM-WOMEN'S HEALTH LINK; Oct 18,2022
;;1.0;WOMEN'S HEALTH;**3,5,7,9,10,16,18,23,25,24,26,28**;Sep 30, 1998;Build 12
;
; Reference to ^RADPT in ICR #2480
; Reference to ^RAMIS(71 in ICR #2481
; Reference to ^RAMIS(71.2 in ICR #2482
; Reference to ^DPT( in ICR #10035
; Reference to ^%ZTLOAD in ICR #10063
; Reference to ^XMD in ICR #10070
; Reference to ^XPDUTL in ICR #10141
; Reference to ^XUPARAM in ICR #2541
; Reference to GETTRMCD^PXRMPRAD in ICR #6808
; Reference to $$EARLDATE^PXRMPRAD in ICR #6808
; Reference to BLDTARR^PXRMPRAD in ICR #6808
;
;; Original routine created by IHS/ANMC/MWR
;;* 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 ^WVEXPTRA WHEN EXPORTING HISTORICAL MAMS TO WOMEN'S HEALTH
;
;---> REQUIRED VARIABLES: DFN = DFN OF RADIOLOGY PATIENT.
;---> DATE = INVERSE DATE/TIME OF VISIT.
;---> CASE = IEN OF RADIOLOGY EXAM (CASE).
;
;---> OPTIONAL VARIABLE: WVNEWP = TOTAL NEW WH PATIENTS ADDED.
;---> WVMCNT = TOTAL NEW MAMS PROCEDURES ADDED.
;---> THESE IF CALLED FROM ^WVEXPTRA ROUTINE.
;
;---> GENERATED VARIBLES:
;---> WVPROC = IEN OF RADIOLOGY PROCEDURE (FILE #71), THEN IT
;---> GETS CHANGED TO WOMEN'S HEALTH PROCEDURE TYPE
;---> (FILE #790.2).
;---> WVLOC = WARD/CLINIC/LOCATION (FILE #44).
;---> WVDATE = DATE OF THE PROCEDURE.
;---> WVPROV = ORDERING PROVIDER.
;---> WVMOD = LEFT OR RIGHT, IF IT'S A UNILATERAL MAMMOGRAM.
;---> WVDX = RADIOLOGY DIAGNOSTIC CODE.
;---> WVBWDX = WOMEN'S HEALTH RESULT/DIAGNOSIS.
;
CREATE(DFN,DATE,CASE) ;
Q:'+$$VERSION^XPDUTL("WV")
Q:($G(DFN)']"")!($G(DATE)']"")!($G(CASE)']"")
N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
S:'$D(DUZ)#2 DUZ=.5
S:'+$G(DUZ(2)) DUZ(2)=$$KSP^XUPARAM("INST")
S ZTRTN="CREATEQ^WVRALINK",ZTDESC="WV CREATE MAMMOGRAM ENTRY"
S ZTSAVE("DFN")="",ZTSAVE("DATE")="",ZTSAVE("CASE")=""
S ZTIO="",ZTDTH=$H
D ^%ZTLOAD
Q
CREATEH(DFN,DATE,CASE,STATUS) ; Entry from ^WVEXPTRA which looks for exams
; created before the WH package was installed.
Q:($G(DFN)']"")!($G(DATE)']"")!($G(CASE)']"")!($G(STATUS)']"")
;
CREATEQ ; Queue data entry creation. Called from CREATE above
N CLOSED,CODES,EARLDATE,ERROR,MATCH,TEMPDATE,TERMIEN,TERMSTAT
N WVPROC,WVLOC,WVDATE,WVDR,WVPROV,WVMOD,WVDX,WVBWDX,WVLEFT,WVRIGHT
N WVCASE,WVCPT,WVERR,WVCREDIT,WVEXAM0,WVTERM,WVZSTAT,WVADDEOC,WVDIV
;---> QUIT IF RADIOLOGY DATA IS NOT DEFINED OR ="".
I $D(ZTQUEUED) S ZTREQ="@"
S CLOSED=0
Q:'$D(^RADPT(DFN,"DT",DATE,"P",CASE,0))
;
;---> QUIT IF THIS PROCEDURE DOES NOT HAVE A MAM CPT CODE.
;---> QUIT IF THIS PROCEDURE DOES NOT HAVE AN ULTRASOUND CPT CODE.
;---> WVEXAM0=ZERO NODE OF RADIOLOGY EXAM.
;AGP pull division from radiology data default to DUZ(2) is none found in radiology
S WVDIV=$$GETRADDIV(DFN,DATE,CASE)
I WVDIV=0,DUZ(2)>0 S WVDIV=DUZ(2)
S WVEXAM0=^RADPT(DFN,"DT",DATE,"P",CASE,0)
S WVCPT=$$GET1^DIQ(71,$P(WVEXAM0,U,2),9,"") Q:WVCPT=""
;check reminder terms
S WVADDEOC=0
S MATCH=0
S TERMIEN=0 F S TERMIEN=$O(^WV(790.2,"RT",TERMIEN)) Q:TERMIEN'>0!($G(WVPROC)'="") D
.K CODES
.D GETTRMCD^PXRMPRAD(TERMIEN,.CODES,.WVTERM,.ERROR)
.I $G(ERROR)'="" Q
.I $D(CODES(WVCPT)) S MATCH=1
.;S WVPROC=$O(^WV(790.2,"RT",TERMIEN,""))
.I MATCH=0,$D(WVTERM("E","RAMIS(71,",$P(WVEXAM0,U,2))) S MATCH=1
.I MATCH=1 D
..S WVPROC=$O(^WV(790.2,"RT",TERMIEN,""))
..S EARLDATE=$$EARLDATE^PXRMPRAD(.WVTERM)
..S TEMPDATE=9999999-$P(DATE,".")
..I EARLDATE>0,TEMPDATE<EARLDATE S CLOSED=1
;check old style of specific CPT code
I +$G(WVPROC)'>0 D
.S WVCPT=$$GET1^DIQ(71,$P(WVEXAM0,U,2),9,"I") Q:WVCPT=""
.S WVPROC=$O(^WV(790.2,"AC",WVCPT,0)) ;cpt code x-ref to get 790.2 ien
Q:+$G(WVPROC)'>0 ;cpt code is not tracked in 790.2
Q:$P($G(^WV(790.2,+WVPROC,0)),U,5)'="R" ;cpt is not rad/nm procedure
Q:$P($G(^DPT(DFN,0)),U,2)'="F" ;not female
;
;---> QUIT IF NO WOMEN'S HEALTH SITE PARAMETER FILE ON THIS MACHINE.
; OR NO DEFAULT CASE MANAGER
Q:'$D(^WV(790.02,WVDIV))
Q:'$P($G(^WV(790.02,WVDIV,0)),U,2)
;
;---> IF NOT CALLED FROM ^WVEXPTRA (i.e., STATUS is undefined) CHECK
;---> SITE PARAMETER AND QUIT IF "IMPORT MAMMOGRAMS FROM RADIOLOGY"
;---> IS NOT SET TO "YES". CHECK VETERAN STATUS AND ELIGIBILITY CODE.
N Y S Y=^WV(790.02,WVDIV,0)
I '$D(STATUS) Q:'$P(Y,U,10)
I '$D(STATUS) Q:'$$VNVEC^WVRALIN1() ;vet/non-vet/eligibility code check
;
;---> SET WVZSTAT =THE STATUS (OPEN OR CLOSED) IN WOMEN'S HEALTH.
;---> THAT MAMMOGRAMS SHOULD RECEIVE WHEN COPIED OVER FROM RADIOLOGY.
I $G(WVZSTAT)="" S WVZSTAT=$P(Y,U,23) S:WVZSTAT="" WVZSTAT="o"
I $G(STATUS)]"" S WVZSTAT=$G(STATUS) ;status selected in ^WVEXPTRA
I CLOSED=1 S WVZSTAT="c"
;
D COPY(WVEXAM0)
;
EXIT ;EP
K I,N,X
Q
;
COMPARE(WVPROC) ;
N NAME,RESULT,TERMIEN,TERMARR,X
S RESULT=0
S TERMIEN=+$P($G(^WV(790.2,WVPROC,3)),U)
I TERMIEN=0 Q RESULT
S NAME=$$GET1^DIQ(811.5,TERMIEN_",",.01)
I NAME="" Q RESULT
D BLDTARR^PXRMPRAD(.TERMARR)
S X=0 F S X=$O(TERMARR(X)) Q:X'>0!(RESULT=1) D
.I TERMARR(X)=NAME S RESULT=1
Q RESULT
;
COPY(Y) ;EP
;---> COPY MAM PROCEDURE DATA FROM RADIOLOGY TO WOMEN'S HEALTH.
;---> VARIABLE DFN=PATIENT
;---> LOCATION=DUZ(2)
;---> WARD/CLINIC/LOCATION
N FDA,IENS,NUM,WVACCESS,WVIEN,WVIEN1,X,WVPVDX
S WVLOC=$P(Y,U,8)
;
S WVPVDX=0
;---> WVDATE=DATE OF THE PROCEDURE.
S WVDATE=$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 WVCASE=$E(WVDATE,4,7)_$E(WVDATE,2,3)_"-"_$P(Y,U)
;---> CHECK TO BE SURE THE CASE# XREF IS REALLY DOWN THERE.
S:'$D(^RADPT("ADC",WVCASE,DFN,DATE,CASE)) WVCASE="UNKNOWN"
;
;AGP TODO begin store off previous diagnosis into new multiple when when a verify report is resent
;comment out the Q: command and remove the comments until AGP TODO END
;---> capture previous info to be moved to the prev diagnosis multiple
;---> QUIT IF THIS PROCEDURE HAS ALREADY BEEN SENT TO WOMEN'S HEALTH.
;Q:$D(^WV(790.1,"E",WVCASE))
I $D(^WV(790.1,"E",WVCASE)) D Q
.S WVIEN1=$O(^WV(790.1,"E",WVCASE,""))
.S WVACCESS=$P($G(^WV(790.1,WVIEN1,0)),U)
.S WVPVDX=$P($G(^WV(790.1,WVIEN1,0)),U,5)
.S WVZSTAT=$P($G(^WV(790.1,WVIEN1,0)),U,14)
.I WVPVDX=0!(WVIEN1=0)!(WVACCESS="") Q
.S WVDX=$P(Y,U,13) I WVDX="" Q
.S WVBWDX=""
.I +WVDX I $D(^WV(790.32,"C",WVDX)) S WVBWDX=$O(^WV(790.32,"C",WVDX,0))
.I WVPVDX=WVBWDX Q
.K WVERR
.S IENS="+2,"_WVIEN1_","
.S FDA(790.1,WVIEN1_",",.01)=WVACCESS
.S FDA(790.1,WVIEN1_",",.05)=$S(WVBWDX="":"@",1:WVBWDX)
.I WVZSTAT'="" S FDA(790.1,WVIEN1_",",.14)=WVZSTAT
.S FDA(790.24,IENS,.01)=WVPVDX
.S FDA(790.24,IENS,1)=$$NOW^XLFDT()
.D UPDATE^DIE("","FDA","","WVERR")
.K WVERR
.D ADD^PXRMEOC(DFN,$$NOW^XLFDT(),+WVIEN1_";WV(790.1,",1,0,"BREAST CARE",.WVERR)
.I '$D(WVERR) Q
.S NUM=0
.S NUM=NUM+1,^TMP("PXRMXMZ",$J,NUM,0)="Error adding Women's Health Procedure to the patient episode file."
.D BLDMSG^WVRPCGF1(DFN,"ERROR Updating Episode of Care File.",.NUM)
;AGP TODO END
;
;---> REQUESTING PROVIDER/ORDERING PROVIDER
S WVPROV=$P(Y,U,14)
;
;---> IF UNILATERAL, ATTEMPT TO PICK UP LEFT OR RIGHT MODIFIER.
I WVPROC=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 WVMOD=$P(^RADPT(DFN,"DT",DATE,"P",CASE,"M",N,0),U)
...S WVMOD=$$GET1^DIQ(71.2,WVMOD,.01,"I")
...I "LEFTleft"[WVMOD S WVLEFT=1
...I "RIGHTright"[WVMOD S WVRIGHT=1
..Q:$D(WVLEFT)&($D(WVRIGHT))
..I $D(WVLEFT) S WVMOD="l" Q
..I $D(WVRIGHT) S WVMOD="r" Q
;
;---> IF THERE'S A DIAGNOSTIC CODE, ATTEMPT TO PICK UP DIAGNOSIS.
;---> USE "WV DIAGNOSTIC CODE TRANSLATION" FILE #790.32.
S WVDX=$P(Y,U,13)
I +WVDX I $D(^WV(790.32,"C",WVDX)) S WVBWDX=$O(^WV(790.32,"C",WVDX,0))
;
;---> GET CREDIT METHOD.
S WVCREDIT=$P(Y,U,26)
;
PATIENT ;---> IF PATIENT ISN'T IN WOMEN'S HEALTH DATABASE, ADD HER.
S WVERR=1
I '$D(^WV(790,DFN,0)) D
.D AUTOADD^WVPATE(DFN,DUZ(2),.WVERR)
.I $D(WVNEWP) S:WVERR WVNEWP=WVNEWP+1
Q:WVERR<0
D FIND^WVRALIN1 ;check for 'unlinked' entry in File 790.1
Q:$D(^WV(790.1,"E",WVCASE)) ;quit if link was made in WVRALIN1
PROC ;---> CREATE MAMMOGRAM PROCEDURE IN WV PROCEDURE FILE #790.1.
;
S WVDR=".02////"_DFN_";.04////"_WVPROC
S WVDR=WVDR_";.05////"_$G(WVBWDX)_";.07////"_WVPROV
S WVDR=WVDR_";.09////"_$G(WVMOD)_";.1////"_DUZ(2)_";.11////"_WVLOC
S WVDR=WVDR_";.12////"_WVDATE_";.14////"_WVZSTAT_";.15////"_WVCASE
S WVDR=WVDR_";.18////.5;.19////"_DT_";.34////"_$G(DUZ(2))_";.35////"_WVCREDIT
;
D NEW2^WVPROC(DFN,WVPROC,WVDATE,WVDR,"","",.WVERR)
I $D(WVMCNT) S:WVERR>-1 WVMCNT=WVMCNT+1
Q:WVERR<0 ;procedure not added
Q:$D(WVMCNT) ;mass import of Rad/NM exams
I +$G(Y)>0,$$COMPARE(WVPROC)>0,WVPVDX=0 D
.K WVERR
.D ADD^PXRMEOC(DFN,$$NOW^XLFDT(),+Y_";WV(790.1,",1,0,"BREAST CARE",.WVERR)
.I '$D(WVERR) Q
.S NUM=0
.S NUM=NUM+1,^TMP("PXRMXMZ",$J,NUM,0)="Error adding Women's Health Procedure to the patient episode file."
.D BLDMSG^WVRPCGF1(DFN,"ERROR Updating Episode of Care File.",.NUM)
;Q:$P($G(^WV(790.02,+DUZ(2),0)),U,23)="c" ;Status=closed
I (WVCPT=76856)!(WVCPT=76830)!(WVCPT=76645) D Q ;not breast related
.D MAIL^WVRADWP(DFN,+Y,WVPROC,WVPROV) ;iens for patient, accession, procedure, provider/requestor
.Q
D CPRS^WVSNOMED(69,DFN,"",WVPROV,"Mammogram results available.",DATE_"~"_CASE)
Q
;
;
DELETE(DFN,DATE,CASE) ;EP
;---> MODIFY WOMEN'S HEALTH PROCEDURE TO REFLECT CHANGE.
;---> CALLED FROM RARTE1 (DELETE A REPORT AND UNVERIFY A REPORT).
;
Q:'+$$VERSION^XPDUTL("WV")
Q:'$D(DFN)!('$D(DATE))!('$D(CASE))
N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
S ZTRTN="DELETEQ^WVRALINK",ZTDESC="WV MAMMOGRAM RPT CHANGE"
S ZTSAVE("DFN")="",ZTSAVE("DATE")="",ZTSAVE("CASE")=""
S ZTIO="",ZTDTH=$H
;D DELETEQ^WVRALINK
D ^%ZTLOAD
Q
DELETEQ ; Modify WV entry when mammogram report is unverified or deleted
Q:'$D(^RADPT(DFN,"DT",DATE,"P",CASE,0))
N WVIEN,WVDATE,WVCASE,WVCMGR,WVLOOP,WVMSG,WVPROV
N XMDUZ,XMSUB,XMTEXT,XMY ;send mail message to case manager
I $D(ZTQUEUED) S ZTREQ="@"
;
;---> WVDATE=DATE OF PROCEDURE.
S WVDATE=$P($P(^RADPT(DFN,"DT",DATE,0),U),".")
S WVCASE=$P(^RADPT(DFN,"DT",DATE,"P",CASE,0),U)
;
;---> WVCASE=RECONSTRUCTED CASE# OF PROCEDURE.
S WVCASE=$E(WVDATE,4,7)_$E(WVDATE,2,3)_"-"_WVCASE
;---> QUIT IF NO CASE# XREF IN WOMEN'S HEALTH PROCEDURE FILE.
Q:'$D(^WV(790.1,"E",WVCASE))
;
S WVIEN=$O(^WV(790.1,"E",WVCASE,0))
Q:'$D(^WV(790.1,WVIEN,0))
;AGP TODO remove auto open a WH procedure when a report is unverified or deleted
;commented out D RADMON^WVPROC
;D RADMOD^WVPROC(WVIEN) ;update wh status to "open"
S WVPROV=+$$GET1^DIQ(790.1,WVIEN,.07,"I") ;get provider/requestor
S WVCMGR=+$$GET1^DIQ(790,DFN,.1,"I") ;get case manager
S:WVCMGR XMY(WVCMGR)=""
; if no case manager, then get default case manager(s)
I 'WVCMGR S WVLOOP=0 F S WVLOOP=$O(^WV(790.02,WVLOOP)) Q:'WVLOOP D
.S WVCMGR=$$GET1^DIQ(790.02,WVLOOP,.02,"I")
.S:WVCMGR XMY(WVCMGR)=""
.Q
Q:$O(XMY(0))'>0 ;no case manager(s)
S:WVPROV XMY(WVPROV)=""
S XMDUZ=.5 ;message sender
S XMSUB="RAD/NM Rpt for WH patient is UNVERIFIED/DELETED"
S WVMSG(1)=" Patient: "_$P($G(^DPT(DFN,0)),U,1)_" (SSN: "_$$SSN^WVUTL1(DFN)_")"
S WVMSG(2)=" WH Accession #: "_$P($G(^WV(790.1,+WVIEN,0)),U,1)
S WVMSG(3)=" RAD/NM Case #: "_WVCASE
S WVMSG(4)=" "
S WVMSG(5)="NOTE: THIS PROCEDURE HAS BEEN ALTERED IN RADIOLOGY/NM."
S WVMSG(6)="Follow-up is required in the WOMEN'S HEALTH package!"
S XMTEXT="WVMSG("
D ^XMD
Q
;
GETRADDIV(DFN,DATE,CASE) ;
N LOC,RADIV,RALOC,RESULT,WVDTNODE,X0
S RESULT=0
;check the radiology division
S WVDTNODE=$G(^RADPT(DFN,"DT",DATE,0))
S RADIV=+$P(WVDTNODE,U,3)
I RADIV>0 S RESULT=+$P($G(^RA(79,RADIV,0)),U)
I RESULT>0 Q RESULT
;last check is for the imaging location type
S RALOC=+$P(WVDTNODE,U,4)
I RALOC=0 Q RESULT
S LOC=+$P($G(^RA(79.1,LOC,0)),U)
I LOC=0 Q RESULT
S RESULT=$$GETLOCDIV(LOC)
Q RESULT
;
GETLOCDIV(LOC) ;
N RESULT
S RESULT=0
S RESULT=$P($G(^SC(+LOC,0)),U,4)
I RESULT>0 Q RESULT
S RESULT=$$INS4LOC^VSITCK1(LOC)
Q RESULT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVRALINK 12611 printed Sep 23, 2025@20:23:53 Page 2
WVRALINK ;HCIOFO/FT - RAD/NM-WOMEN'S HEALTH LINK; Oct 18,2022
+1 ;;1.0;WOMEN'S HEALTH;**3,5,7,9,10,16,18,23,25,24,26,28**;Sep 30, 1998;Build 12
+2 ;
+3 ; Reference to ^RADPT in ICR #2480
+4 ; Reference to ^RAMIS(71 in ICR #2481
+5 ; Reference to ^RAMIS(71.2 in ICR #2482
+6 ; Reference to ^DPT( in ICR #10035
+7 ; Reference to ^%ZTLOAD in ICR #10063
+8 ; Reference to ^XMD in ICR #10070
+9 ; Reference to ^XPDUTL in ICR #10141
+10 ; Reference to ^XUPARAM in ICR #2541
+11 ; Reference to GETTRMCD^PXRMPRAD in ICR #6808
+12 ; Reference to $$EARLDATE^PXRMPRAD in ICR #6808
+13 ; Reference to BLDTARR^PXRMPRAD in ICR #6808
+14 ;
+15 ;; Original routine created by IHS/ANMC/MWR
+16 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+17 ;; CREATE MAMMOGRAM PROCEDURE IN WOMEN'S HEALTH FOR THIS PATIENT.
+18 ;; CALLED BY ^RART WHEN A RADIOLOGY REPORT IS VERIFIED.
+19 ;; CALLED BY ^RARTE1 WHEN A RADIOLOGY REPORT IS UNVERIFIED.
+20 ;; CALLED BY ^WVEXPTRA WHEN EXPORTING HISTORICAL MAMS TO WOMEN'S HEALTH
+21 ;
+22 ;---> REQUIRED VARIABLES: DFN = DFN OF RADIOLOGY PATIENT.
+23 ;---> DATE = INVERSE DATE/TIME OF VISIT.
+24 ;---> CASE = IEN OF RADIOLOGY EXAM (CASE).
+25 ;
+26 ;---> OPTIONAL VARIABLE: WVNEWP = TOTAL NEW WH PATIENTS ADDED.
+27 ;---> WVMCNT = TOTAL NEW MAMS PROCEDURES ADDED.
+28 ;---> THESE IF CALLED FROM ^WVEXPTRA ROUTINE.
+29 ;
+30 ;---> GENERATED VARIBLES:
+31 ;---> WVPROC = IEN OF RADIOLOGY PROCEDURE (FILE #71), THEN IT
+32 ;---> GETS CHANGED TO WOMEN'S HEALTH PROCEDURE TYPE
+33 ;---> (FILE #790.2).
+34 ;---> WVLOC = WARD/CLINIC/LOCATION (FILE #44).
+35 ;---> WVDATE = DATE OF THE PROCEDURE.
+36 ;---> WVPROV = ORDERING PROVIDER.
+37 ;---> WVMOD = LEFT OR RIGHT, IF IT'S A UNILATERAL MAMMOGRAM.
+38 ;---> WVDX = RADIOLOGY DIAGNOSTIC CODE.
+39 ;---> WVBWDX = WOMEN'S HEALTH RESULT/DIAGNOSIS.
+40 ;
CREATE(DFN,DATE,CASE) ;
+1 if '+$$VERSION^XPDUTL("WV")
QUIT
+2 if ($GET(DFN)']"")!($GET(DATE)']"")!($GET(CASE)']"")
QUIT
+3 NEW ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+4 if '$DATA(DUZ)#2
SET DUZ=.5
+5 if '+$GET(DUZ(2))
SET DUZ(2)=$$KSP^XUPARAM("INST")
+6 SET ZTRTN="CREATEQ^WVRALINK"
SET ZTDESC="WV CREATE MAMMOGRAM ENTRY"
+7 SET ZTSAVE("DFN")=""
SET ZTSAVE("DATE")=""
SET ZTSAVE("CASE")=""
+8 SET ZTIO=""
SET ZTDTH=$HOROLOG
+9 DO ^%ZTLOAD
+10 QUIT
CREATEH(DFN,DATE,CASE,STATUS) ; Entry from ^WVEXPTRA which looks for exams
+1 ; created before the WH package was installed.
+2 if ($GET(DFN)']"")!($GET(DATE)']"")!($GET(CASE)']"")!($GET(STATUS)']"")
QUIT
+3 ;
CREATEQ ; Queue data entry creation. Called from CREATE above
+1 NEW CLOSED,CODES,EARLDATE,ERROR,MATCH,TEMPDATE,TERMIEN,TERMSTAT
+2 NEW WVPROC,WVLOC,WVDATE,WVDR,WVPROV,WVMOD,WVDX,WVBWDX,WVLEFT,WVRIGHT
+3 NEW WVCASE,WVCPT,WVERR,WVCREDIT,WVEXAM0,WVTERM,WVZSTAT,WVADDEOC,WVDIV
+4 ;---> QUIT IF RADIOLOGY DATA IS NOT DEFINED OR ="".
+5 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+6 SET CLOSED=0
+7 if '$DATA(^RADPT(DFN,"DT",DATE,"P",CASE,0))
QUIT
+8 ;
+9 ;---> QUIT IF THIS PROCEDURE DOES NOT HAVE A MAM CPT CODE.
+10 ;---> QUIT IF THIS PROCEDURE DOES NOT HAVE AN ULTRASOUND CPT CODE.
+11 ;---> WVEXAM0=ZERO NODE OF RADIOLOGY EXAM.
+12 ;AGP pull division from radiology data default to DUZ(2) is none found in radiology
+13 SET WVDIV=$$GETRADDIV(DFN,DATE,CASE)
+14 IF WVDIV=0
IF DUZ(2)>0
SET WVDIV=DUZ(2)
+15 SET WVEXAM0=^RADPT(DFN,"DT",DATE,"P",CASE,0)
+16 SET WVCPT=$$GET1^DIQ(71,$PIECE(WVEXAM0,U,2),9,"")
if WVCPT=""
QUIT
+17 ;check reminder terms
+18 SET WVADDEOC=0
+19 SET MATCH=0
+20 SET TERMIEN=0
FOR
SET TERMIEN=$ORDER(^WV(790.2,"RT",TERMIEN))
if TERMIEN'>0!($GET(WVPROC)'="")
QUIT
Begin DoDot:1
+21 KILL CODES
+22 DO GETTRMCD^PXRMPRAD(TERMIEN,.CODES,.WVTERM,.ERROR)
+23 IF $GET(ERROR)'=""
QUIT
+24 IF $DATA(CODES(WVCPT))
SET MATCH=1
+25 ;S WVPROC=$O(^WV(790.2,"RT",TERMIEN,""))
+26 IF MATCH=0
IF $DATA(WVTERM("E","RAMIS(71,",$PIECE(WVEXAM0,U,2)))
SET MATCH=1
+27 IF MATCH=1
Begin DoDot:2
+28 SET WVPROC=$ORDER(^WV(790.2,"RT",TERMIEN,""))
+29 SET EARLDATE=$$EARLDATE^PXRMPRAD(.WVTERM)
+30 SET TEMPDATE=9999999-$PIECE(DATE,".")
+31 IF EARLDATE>0
IF TEMPDATE<EARLDATE
SET CLOSED=1
End DoDot:2
End DoDot:1
+32 ;check old style of specific CPT code
+33 IF +$GET(WVPROC)'>0
Begin DoDot:1
+34 SET WVCPT=$$GET1^DIQ(71,$PIECE(WVEXAM0,U,2),9,"I")
if WVCPT=""
QUIT
+35 ;cpt code x-ref to get 790.2 ien
SET WVPROC=$ORDER(^WV(790.2,"AC",WVCPT,0))
End DoDot:1
+36 ;cpt code is not tracked in 790.2
if +$GET(WVPROC)'>0
QUIT
+37 ;cpt is not rad/nm procedure
if $PIECE($GET(^WV(790.2,+WVPROC,0)),U,5)'="R"
QUIT
+38 ;not female
if $PIECE($GET(^DPT(DFN,0)),U,2)'="F"
QUIT
+39 ;
+40 ;---> QUIT IF NO WOMEN'S HEALTH SITE PARAMETER FILE ON THIS MACHINE.
+41 ; OR NO DEFAULT CASE MANAGER
+42 if '$DATA(^WV(790.02,WVDIV))
QUIT
+43 if '$PIECE($GET(^WV(790.02,WVDIV,0)),U,2)
QUIT
+44 ;
+45 ;---> IF NOT CALLED FROM ^WVEXPTRA (i.e., STATUS is undefined) CHECK
+46 ;---> SITE PARAMETER AND QUIT IF "IMPORT MAMMOGRAMS FROM RADIOLOGY"
+47 ;---> IS NOT SET TO "YES". CHECK VETERAN STATUS AND ELIGIBILITY CODE.
+48 NEW Y
SET Y=^WV(790.02,WVDIV,0)
+49 IF '$DATA(STATUS)
if '$PIECE(Y,U,10)
QUIT
+50 ;vet/non-vet/eligibility code check
IF '$DATA(STATUS)
if '$$VNVEC^WVRALIN1()
QUIT
+51 ;
+52 ;---> SET WVZSTAT =THE STATUS (OPEN OR CLOSED) IN WOMEN'S HEALTH.
+53 ;---> THAT MAMMOGRAMS SHOULD RECEIVE WHEN COPIED OVER FROM RADIOLOGY.
+54 IF $GET(WVZSTAT)=""
SET WVZSTAT=$PIECE(Y,U,23)
if WVZSTAT=""
SET WVZSTAT="o"
+55 ;status selected in ^WVEXPTRA
IF $GET(STATUS)]""
SET WVZSTAT=$GET(STATUS)
+56 IF CLOSED=1
SET WVZSTAT="c"
+57 ;
+58 DO COPY(WVEXAM0)
+59 ;
EXIT ;EP
+1 KILL I,N,X
+2 QUIT
+3 ;
COMPARE(WVPROC) ;
+1 NEW NAME,RESULT,TERMIEN,TERMARR,X
+2 SET RESULT=0
+3 SET TERMIEN=+$PIECE($GET(^WV(790.2,WVPROC,3)),U)
+4 IF TERMIEN=0
QUIT RESULT
+5 SET NAME=$$GET1^DIQ(811.5,TERMIEN_",",.01)
+6 IF NAME=""
QUIT RESULT
+7 DO BLDTARR^PXRMPRAD(.TERMARR)
+8 SET X=0
FOR
SET X=$ORDER(TERMARR(X))
if X'>0!(RESULT=1)
QUIT
Begin DoDot:1
+9 IF TERMARR(X)=NAME
SET RESULT=1
End DoDot:1
+10 QUIT RESULT
+11 ;
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 FDA,IENS,NUM,WVACCESS,WVIEN,WVIEN1,X,WVPVDX
+6 SET WVLOC=$PIECE(Y,U,8)
+7 ;
+8 SET WVPVDX=0
+9 ;---> WVDATE=DATE OF THE PROCEDURE.
+10 SET WVDATE=$PIECE($PIECE(^RADPT(DFN,"DT",DATE,0),U),".")
+11 ;
+12 ;---> RECONSTRUCT THE FULL CASE# FOR THIS RAD PROCEDURE.
+13 ;---> THIS IS USED AS A LINK (XREF) BETWEEN THE RADIOLOGY PROCEDURE
+14 ;---> AND THE WOMEN'S HEALTH PROCEDURE.
+15 SET WVCASE=$EXTRACT(WVDATE,4,7)_$EXTRACT(WVDATE,2,3)_"-"_$PIECE(Y,U)
+16 ;---> CHECK TO BE SURE THE CASE# XREF IS REALLY DOWN THERE.
+17 if '$DATA(^RADPT("ADC",WVCASE,DFN,DATE,CASE))
SET WVCASE="UNKNOWN"
+18 ;
+19 ;AGP TODO begin store off previous diagnosis into new multiple when when a verify report is resent
+20 ;comment out the Q: command and remove the comments until AGP TODO END
+21 ;---> capture previous info to be moved to the prev diagnosis multiple
+22 ;---> QUIT IF THIS PROCEDURE HAS ALREADY BEEN SENT TO WOMEN'S HEALTH.
+23 ;Q:$D(^WV(790.1,"E",WVCASE))
+24 IF $DATA(^WV(790.1,"E",WVCASE))
Begin DoDot:1
+25 SET WVIEN1=$ORDER(^WV(790.1,"E",WVCASE,""))
+26 SET WVACCESS=$PIECE($GET(^WV(790.1,WVIEN1,0)),U)
+27 SET WVPVDX=$PIECE($GET(^WV(790.1,WVIEN1,0)),U,5)
+28 SET WVZSTAT=$PIECE($GET(^WV(790.1,WVIEN1,0)),U,14)
+29 IF WVPVDX=0!(WVIEN1=0)!(WVACCESS="")
QUIT
+30 SET WVDX=$PIECE(Y,U,13)
IF WVDX=""
QUIT
+31 SET WVBWDX=""
+32 IF +WVDX
IF $DATA(^WV(790.32,"C",WVDX))
SET WVBWDX=$ORDER(^WV(790.32,"C",WVDX,0))
+33 IF WVPVDX=WVBWDX
QUIT
+34 KILL WVERR
+35 SET IENS="+2,"_WVIEN1_","
+36 SET FDA(790.1,WVIEN1_",",.01)=WVACCESS
+37 SET FDA(790.1,WVIEN1_",",.05)=$SELECT(WVBWDX="":"@",1:WVBWDX)
+38 IF WVZSTAT'=""
SET FDA(790.1,WVIEN1_",",.14)=WVZSTAT
+39 SET FDA(790.24,IENS,.01)=WVPVDX
+40 SET FDA(790.24,IENS,1)=$$NOW^XLFDT()
+41 DO UPDATE^DIE("","FDA","","WVERR")
+42 KILL WVERR
+43 DO ADD^PXRMEOC(DFN,$$NOW^XLFDT(),+WVIEN1_";WV(790.1,",1,0,"BREAST CARE",.WVERR)
+44 IF '$DATA(WVERR)
QUIT
+45 SET NUM=0
+46 SET NUM=NUM+1
SET ^TMP("PXRMXMZ",$JOB,NUM,0)="Error adding Women's Health Procedure to the patient episode file."
+47 DO BLDMSG^WVRPCGF1(DFN,"ERROR Updating Episode of Care File.",.NUM)
End DoDot:1
QUIT
+48 ;AGP TODO END
+49 ;
+50 ;---> REQUESTING PROVIDER/ORDERING PROVIDER
+51 SET WVPROV=$PIECE(Y,U,14)
+52 ;
+53 ;---> IF UNILATERAL, ATTEMPT TO PICK UP LEFT OR RIGHT MODIFIER.
+54 IF WVPROC=26
Begin DoDot:1
+55 IF $DATA(^RADPT(DFN,"DT",DATE,"P",CASE,"M",0))
Begin DoDot:2
+56 NEW N
SET N=0
+57 FOR
SET N=$ORDER(^RADPT(DFN,"DT",DATE,"P",CASE,"M",N))
if 'N
QUIT
Begin DoDot:3
+58 SET WVMOD=$PIECE(^RADPT(DFN,"DT",DATE,"P",CASE,"M",N,0),U)
+59 SET WVMOD=$$GET1^DIQ(71.2,WVMOD,.01,"I")
+60 IF "LEFTleft"[WVMOD
SET WVLEFT=1
+61 IF "RIGHTright"[WVMOD
SET WVRIGHT=1
End DoDot:3
+62 if $DATA(WVLEFT)&($DATA(WVRIGHT))
QUIT
+63 IF $DATA(WVLEFT)
SET WVMOD="l"
QUIT
+64 IF $DATA(WVRIGHT)
SET WVMOD="r"
QUIT
End DoDot:2
End DoDot:1
+65 ;
+66 ;---> IF THERE'S A DIAGNOSTIC CODE, ATTEMPT TO PICK UP DIAGNOSIS.
+67 ;---> USE "WV DIAGNOSTIC CODE TRANSLATION" FILE #790.32.
+68 SET WVDX=$PIECE(Y,U,13)
+69 IF +WVDX
IF $DATA(^WV(790.32,"C",WVDX))
SET WVBWDX=$ORDER(^WV(790.32,"C",WVDX,0))
+70 ;
+71 ;---> GET CREDIT METHOD.
+72 SET WVCREDIT=$PIECE(Y,U,26)
+73 ;
PATIENT ;---> IF PATIENT ISN'T IN WOMEN'S HEALTH DATABASE, ADD HER.
+1 SET WVERR=1
+2 IF '$DATA(^WV(790,DFN,0))
Begin DoDot:1
+3 DO AUTOADD^WVPATE(DFN,DUZ(2),.WVERR)
+4 IF $DATA(WVNEWP)
if WVERR
SET WVNEWP=WVNEWP+1
End DoDot:1
+5 if WVERR<0
QUIT
+6 ;check for 'unlinked' entry in File 790.1
DO FIND^WVRALIN1
+7 ;quit if link was made in WVRALIN1
if $DATA(^WV(790.1,"E",WVCASE))
QUIT
PROC ;---> CREATE MAMMOGRAM PROCEDURE IN WV PROCEDURE FILE #790.1.
+1 ;
+2 SET WVDR=".02////"_DFN_";.04////"_WVPROC
+3 SET WVDR=WVDR_";.05////"_$GET(WVBWDX)_";.07////"_WVPROV
+4 SET WVDR=WVDR_";.09////"_$GET(WVMOD)_";.1////"_DUZ(2)_";.11////"_WVLOC
+5 SET WVDR=WVDR_";.12////"_WVDATE_";.14////"_WVZSTAT_";.15////"_WVCASE
+6 SET WVDR=WVDR_";.18////.5;.19////"_DT_";.34////"_$GET(DUZ(2))_";.35////"_WVCREDIT
+7 ;
+8 DO NEW2^WVPROC(DFN,WVPROC,WVDATE,WVDR,"","",.WVERR)
+9 IF $DATA(WVMCNT)
if WVERR>-1
SET WVMCNT=WVMCNT+1
+10 ;procedure not added
if WVERR<0
QUIT
+11 ;mass import of Rad/NM exams
if $DATA(WVMCNT)
QUIT
+12 IF +$GET(Y)>0
IF $$COMPARE(WVPROC)>0
IF WVPVDX=0
Begin DoDot:1
+13 KILL WVERR
+14 DO ADD^PXRMEOC(DFN,$$NOW^XLFDT(),+Y_";WV(790.1,",1,0,"BREAST CARE",.WVERR)
+15 IF '$DATA(WVERR)
QUIT
+16 SET NUM=0
+17 SET NUM=NUM+1
SET ^TMP("PXRMXMZ",$JOB,NUM,0)="Error adding Women's Health Procedure to the patient episode file."
+18 DO BLDMSG^WVRPCGF1(DFN,"ERROR Updating Episode of Care File.",.NUM)
End DoDot:1
+19 ;Q:$P($G(^WV(790.02,+DUZ(2),0)),U,23)="c" ;Status=closed
+20 ;not breast related
IF (WVCPT=76856)!(WVCPT=76830)!(WVCPT=76645)
Begin DoDot:1
+21 ;iens for patient, accession, procedure, provider/requestor
DO MAIL^WVRADWP(DFN,+Y,WVPROC,WVPROV)
+22 QUIT
End DoDot:1
QUIT
+23 DO CPRS^WVSNOMED(69,DFN,"",WVPROV,"Mammogram results available.",DATE_"~"_CASE)
+24 QUIT
+25 ;
+26 ;
DELETE(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 ;
+4 if '+$$VERSION^XPDUTL("WV")
QUIT
+5 if '$DATA(DFN)!('$DATA(DATE))!('$DATA(CASE))
QUIT
+6 NEW ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+7 SET ZTRTN="DELETEQ^WVRALINK"
SET ZTDESC="WV MAMMOGRAM RPT CHANGE"
+8 SET ZTSAVE("DFN")=""
SET ZTSAVE("DATE")=""
SET ZTSAVE("CASE")=""
+9 SET ZTIO=""
SET ZTDTH=$HOROLOG
+10 ;D DELETEQ^WVRALINK
+11 DO ^%ZTLOAD
+12 QUIT
DELETEQ ; Modify WV entry when mammogram report is unverified or deleted
+1 if '$DATA(^RADPT(DFN,"DT",DATE,"P",CASE,0))
QUIT
+2 NEW WVIEN,WVDATE,WVCASE,WVCMGR,WVLOOP,WVMSG,WVPROV
+3 ;send mail message to case manager
NEW XMDUZ,XMSUB,XMTEXT,XMY
+4 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 ;
+6 ;---> WVDATE=DATE OF PROCEDURE.
+7 SET WVDATE=$PIECE($PIECE(^RADPT(DFN,"DT",DATE,0),U),".")
+8 SET WVCASE=$PIECE(^RADPT(DFN,"DT",DATE,"P",CASE,0),U)
+9 ;
+10 ;---> WVCASE=RECONSTRUCTED CASE# OF PROCEDURE.
+11 SET WVCASE=$EXTRACT(WVDATE,4,7)_$EXTRACT(WVDATE,2,3)_"-"_WVCASE
+12 ;---> QUIT IF NO CASE# XREF IN WOMEN'S HEALTH PROCEDURE FILE.
+13 if '$DATA(^WV(790.1,"E",WVCASE))
QUIT
+14 ;
+15 SET WVIEN=$ORDER(^WV(790.1,"E",WVCASE,0))
+16 if '$DATA(^WV(790.1,WVIEN,0))
QUIT
+17 ;AGP TODO remove auto open a WH procedure when a report is unverified or deleted
+18 ;commented out D RADMON^WVPROC
+19 ;D RADMOD^WVPROC(WVIEN) ;update wh status to "open"
+20 ;get provider/requestor
SET WVPROV=+$$GET1^DIQ(790.1,WVIEN,.07,"I")
+21 ;get case manager
SET WVCMGR=+$$GET1^DIQ(790,DFN,.1,"I")
+22 if WVCMGR
SET XMY(WVCMGR)=""
+23 ; if no case manager, then get default case manager(s)
+24 IF 'WVCMGR
SET WVLOOP=0
FOR
SET WVLOOP=$ORDER(^WV(790.02,WVLOOP))
if 'WVLOOP
QUIT
Begin DoDot:1
+25 SET WVCMGR=$$GET1^DIQ(790.02,WVLOOP,.02,"I")
+26 if WVCMGR
SET XMY(WVCMGR)=""
+27 QUIT
End DoDot:1
+28 ;no case manager(s)
if $ORDER(XMY(0))'>0
QUIT
+29 if WVPROV
SET XMY(WVPROV)=""
+30 ;message sender
SET XMDUZ=.5
+31 SET XMSUB="RAD/NM Rpt for WH patient is UNVERIFIED/DELETED"
+32 SET WVMSG(1)=" Patient: "_$PIECE($GET(^DPT(DFN,0)),U,1)_" (SSN: "_$$SSN^WVUTL1(DFN)_")"
+33 SET WVMSG(2)=" WH Accession #: "_$PIECE($GET(^WV(790.1,+WVIEN,0)),U,1)
+34 SET WVMSG(3)=" RAD/NM Case #: "_WVCASE
+35 SET WVMSG(4)=" "
+36 SET WVMSG(5)="NOTE: THIS PROCEDURE HAS BEEN ALTERED IN RADIOLOGY/NM."
+37 SET WVMSG(6)="Follow-up is required in the WOMEN'S HEALTH package!"
+38 SET XMTEXT="WVMSG("
+39 DO ^XMD
+40 QUIT
+41 ;
GETRADDIV(DFN,DATE,CASE) ;
+1 NEW LOC,RADIV,RALOC,RESULT,WVDTNODE,X0
+2 SET RESULT=0
+3 ;check the radiology division
+4 SET WVDTNODE=$GET(^RADPT(DFN,"DT",DATE,0))
+5 SET RADIV=+$PIECE(WVDTNODE,U,3)
+6 IF RADIV>0
SET RESULT=+$PIECE($GET(^RA(79,RADIV,0)),U)
+7 IF RESULT>0
QUIT RESULT
+8 ;last check is for the imaging location type
+9 SET RALOC=+$PIECE(WVDTNODE,U,4)
+10 IF RALOC=0
QUIT RESULT
+11 SET LOC=+$PIECE($GET(^RA(79.1,LOC,0)),U)
+12 IF LOC=0
QUIT RESULT
+13 SET RESULT=$$GETLOCDIV(LOC)
+14 QUIT RESULT
+15 ;
GETLOCDIV(LOC) ;
+1 NEW RESULT
+2 SET RESULT=0
+3 SET RESULT=$PIECE($GET(^SC(+LOC,0)),U,4)
+4 IF RESULT>0
QUIT RESULT
+5 SET RESULT=$$INS4LOC^VSITCK1(LOC)
+6 QUIT RESULT
