Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: WVRALINK

WVRALINK.m

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