- 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 Jan 18, 2025@03:48:42 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