Changeset 623 for WorldVistAEHR/trunk/r/WOMENS_HEALTH-WV
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- Location:
- WorldVistAEHR/trunk/r/WOMENS_HEALTH-WV
- Files:
-
- 3 edited
-
WVLABCHK.m (modified) (1 diff)
-
WVRALINK.m (modified) (1 diff)
-
WVSNOMED.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/WOMENS_HEALTH-WV/WVLABCHK.m
r613 r623 1 WVLABCHK ;HIOFO/FT-IS LAB TEST A PAP SMEAR? ;10/25/04 10:23 2 ;;1.0;WOMEN'S HEALTH;**16,23**;Sep 30, 1998;Build 5 3 ; 4 ; This routine uses the following IAs: 5 ; #525 - ^LR references (controlled) 6 ; #4298 - ^LR references (private) 7 ; #10103 - ^XLFDT calls (supported) 8 ; #10063 - ^%ZTLOAD (supported) 9 ; #10141 - ^XPDUTL (supported) 10 ; #10035 - ^DPT (supported) 11 ; 12 ; This routine supports the following IAs: 13 ; CREATE - 4525 14 ; 15 CREATE(DFN,LRDFN,LRI,LRA,LRSS) ; 16 ; Add lab test to WH file (#790.08). 17 ; Called by REPORT RELEASE DATE/TIME field in: 18 ; a) File 63, Field 63.08,.11 19 ; b) File 63, Field 63.09,.11 20 ; Input: DFN = PATIENT DFN 21 ; LRDFN = FILE 63 IEN (+^DPT(DFN,"LR")) 22 ; LRI = INVERSE DATE/TIME OF TEST 23 ; LRA = ZERO NODE OF THE CY or SP ENTRY 24 ; LRSS = File 63 subscript (e.g., CY or SP) 25 ; 26 Q:($G(DFN)']"")!($G(LRDFN)']"")!($G(LRI)']"")!($G(LRA)']"")!($G(LRSS)']"") 27 Q:'$D(^WV(790.02,DUZ(2))) ;no site parameter entry 28 Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,24) ;lab link is NO or null 29 N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE 30 S ZTRTN="CREATEQ^WVLABCHK",ZTDESC="WV CHECK SNOMED CODE CHANGES" 31 S ZTSAVE("DFN")="",ZTSAVE("LRDFN")="",ZTSAVE("LRI")="",ZTSAVE("LRA")="" 32 S ZTSAVE("LRSS")="",ZTIO="" 33 S ZTDTH=$$HADD^XLFDT($H,"","","",150) ;don't want the SNOMED trigger to 34 ; conflict with the report verification trigger 35 D ^%ZTLOAD 36 Q 37 CREATEQ ; Called from CREATE above 38 I $D(ZTQUEUED) S ZTREQ="@" 39 N WVDATE,WVDFN,WVDUZ2,WVIEN,WVLABAN,WVLOC,WVLRDFN,WVLRI,WVLRSS,WVNODE,WVPAP,WVPIEN,WVPROV,WVTOP,X,Y 40 Q:$P($G(^DPT(DFN,0)),U,2)'="F" ;not female 41 S WVLABAN=$P(LRA,U,6) ;lab accession# 42 Q:$D(^WV(790.1,"F",WVLABAN)) ;already tracked 43 ; check WH site parameters 44 Q:'$D(^WV(790.02,DUZ(2))) ;no site parameter entry 45 Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,24) ;lab link is NO or null 46 Q:'$$VNVEC^WVLRLINK() ;vet/non-vet/eligibility code check 47 D CODES ;what SNOMED codes are we looking for? 48 I WVTOP(0)=0 Q ;no SNOMED codes identified 49 S WVPIEN=$$PAPIEN^WVRPCPR() 50 Q:'WVPIEN 51 S WVIEN=$O(^WV(790.08,"B",WVLABAN,0)) 52 Q:'WVIEN 53 S WVNODE=$G(^WV(790.08,WVIEN,0)) 54 Q:WVNODE="" 55 S WVLRDFN=$P(WVNODE,U,36) 56 Q:'WVLRDFN 57 S WVLRI=$P(WVNODE,U,37) 58 Q:'WVLRI 59 S WVLRSS=$P(WVNODE,U,38) 60 S WVDFN=$P(WVNODE,U,2) 61 S WVPROV=$P(WVNODE,U,7) 62 S WVLOC=$P(WVNODE,U,11) 63 S WVDATE=$P(WVNODE,U,12) 64 S WVLABAN=$P(WVNODE,U,1) 65 S WVDUZ2=$P(WVNODE,U,10) 66 I WVLRSS="CY" D Q 67 .S WVPAP=$$CY() 68 .D:WVPAP ADD 69 .Q 70 I WVLRSS="SP" D Q 71 .S WVPAP=$$SP() 72 .D:WVPAP ADD 73 .Q 74 Q 75 ; 76 CODES ; WVTOP array identifies SNOMED codes (IENS) used for pap smears 77 N WVPIEN,WVPIEN1,WVSNOMED 78 S WVTOP(0)=0 79 S WVPIEN=$$PAPIEN^WVRPCPR() 80 I 'WVPIEN Q ;pap smear procedure not identified 81 S WVPIEN1=0 82 F S WVPIEN1=$O(^WV(790.2,WVPIEN,2,WVPIEN1)) Q:'WVPIEN1 D 83 .S WVSNOMED=$P($G(^WV(790.2,WVPIEN,2,WVPIEN1,0)),U,1) 84 .Q:'WVSNOMED 85 .S WVTOP(0)=WVTOP(0)+1 86 .S WVTOP(WVSNOMED)="" 87 .Q 88 Q 89 CY() ; Check SNOMED codes used by cytology entry 90 N WVFLAG,WVLOOP,WVSNOMED 91 S (WVFLAG,WVLOOP)=0 92 ; check topography multiple 93 F S WVLOOP=$O(^LR(WVLRDFN,"CY",WVLRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1) D 94 .S WVSNOMED=+$P($G(^LR(WVLRDFN,"CY",WVLRI,2,WVLOOP,0)),U,1) 95 .Q:'WVSNOMED 96 .I $D(WVTOP(WVSNOMED)) S WVFLAG=1 97 .Q 98 Q WVFLAG 99 ; 100 SP() ; Check SNOMED codes used by surgical pathology entry 101 N WVFLAG,WVLOOP,WVSNOMED 102 ; check topography multiple 103 S (WVFLAG,WVLOOP)=0 104 F S WVLOOP=$O(^LR(WVLRDFN,"SP",WVLRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1) D 105 .S WVSNOMED=+$P($G(^LR(WVLRDFN,"SP",WVLRI,2,WVLOOP,0)),U,1) 106 .Q:'WVSNOMED 107 .I $D(WVTOP(WVSNOMED)) S WVFLAG=1 108 .Q 109 Q WVFLAG 110 ; 111 ADD ; Add pap smear to FILE 790.1 112 N WVDR,WVERR 113 S WVERR=0 114 I '$D(^WV(790,WVDFN,0)) D ;add patient to File 790, if not there 115 .D AUTOADD^WVPATE(WVDFN,WVDUZ2,.WVERR) 116 .Q 117 Q:WVERR<0 ;quit if new patient could not be added to File 790 118 S WVDR=".02////"_WVDFN 119 S WVDR=WVDR_";.04////"_WVPIEN ;File 790.2 pointer 120 S:WVPROV]"" WVDR=WVDR_";.07////"_WVPROV ;provider 121 S WVDR=WVDR_";.1////"_WVDUZ2 ;health care facility 122 S:WVLOC]"" WVDR=WVDR_";.11////"_WVLOC ;patient location 123 S WVDR=WVDR_";.12////"_WVDATE ;procedure date/time 124 S WVDR=WVDR_";.14////"_"o" ;status 125 S WVDR=WVDR_";.18////.5;.19////"_DT ;entering user and date 126 S WVDR=WVDR_";.34////"_WVDUZ2 ;accessioning facility 127 S WVDR=WVDR_";2.17////"_WVLABAN ;lab accession# 128 S WVDR=WVDR_";2.18////"_WVLRDFN ;Lab Data file (#63) pointer 129 S WVDR=WVDR_";2.19////"_WVLRI ;Lab Data file inverse d/t 130 S WVDR=WVDR_";2.2////"_WVLRSS ;Lab Data file subscript (CY/SP) 131 ; add procedure to File 790.1 132 D NEW2^WVPROC(WVDFN,WVPIEN,WVDATE,WVDR,"","",.WVERR) 133 Q:'Y 134 I $$PATCH^XPDUTL("OR*3.0*210") D 135 .D CPRS^WVSNOMED(70,WVDFN,"",WVPROV,"Pap Smear results available.",WVLRSS_U_WVLABAN_U_WVLRI) 136 .D DELETE^WVLABADD(WVIEN) 137 .Q 138 Q 1 WVLABCHK ;HIOFO/FT-IS LAB TEST A PAP SMEAR? ;10/25/04 10:23 2 ;;1.0;WOMEN'S HEALTH;**16**;Sep 30, 1998 3 ; 4 ; This routine uses the following IAs: 5 ; #525 - ^LR references (controlled) 6 ; #4298 - ^LR references (private) 7 ; #10103 - ^XLFDT calls (supported) 8 ; #10063 - ^%ZTLOAD (supported) 9 ; #10141 - ^XPDUTL (supported) 10 ; 11 ; This routine supports the following IAs: 12 ; CREATE - 4525 13 ; 14 CREATE(DFN,LRDFN,LRI,LRA,LRSS) ; 15 ; Add lab test to WH file (#790.08). 16 ; Called by REPORT RELEASE DATE/TIME field in: 17 ; a) File 63, Field 63.08,.11 18 ; b) File 63, Field 63.09,.11 19 ; Input: DFN = PATIENT DFN 20 ; LRDFN = FILE 63 IEN (+^DPT(DFN,"LR")) 21 ; LRI = INVERSE DATE/TIME OF TEST 22 ; LRA = ZERO NODE OF THE CY or SP ENTRY 23 ; LRSS = File 63 subscript (e.g., CY or SP) 24 ; 25 Q:($G(DFN)']"")!($G(LRDFN)']"")!($G(LRI)']"")!($G(LRA)']"")!($G(LRSS)']"") 26 Q:'$D(^WV(790.02,DUZ(2))) ;no site parameter entry 27 Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,24) ;lab link is NO or null 28 N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE 29 S ZTRTN="CREATEQ^WVLABCHK",ZTDESC="WV CHECK SNOMED CODE CHANGES" 30 S ZTSAVE("DFN")="",ZTSAVE("LRDFN")="",ZTSAVE("LRI")="",ZTSAVE("LRA")="" 31 S ZTSAVE("LRSS")="",ZTIO="" 32 S ZTDTH=$$HADD^XLFDT($H,"","","",150) ;don't want the SNOMED trigger to 33 ; conflict with the report verification trigger 34 D ^%ZTLOAD 35 Q 36 CREATEQ ; Called from CREATE above 37 I $D(ZTQUEUED) S ZTREQ="@" 38 N WVDATE,WVDFN,WVDUZ2,WVIEN,WVLABAN,WVLOC,WVLRDFN,WVLRI,WVLRSS,WVNODE,WVPAP,WVPIEN,WVPROV,WVTOP,X,Y 39 Q:$P($G(^DPT(DFN,0)),U,2)'="F" ;not female 40 S WVLABAN=$P(LRA,U,6) ;lab accession# 41 Q:$D(^WV(790.1,"F",WVLABAN)) ;already tracked 42 ; check WH site parameters 43 Q:'$D(^WV(790.02,DUZ(2))) ;no site parameter entry 44 Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,24) ;lab link is NO or null 45 Q:'$$VNVEC^WVLRLINK() ;vet/non-vet/eligibility code check 46 D CODES ;what SNOMED codes are we looking for? 47 I WVTOP(0)=0 Q ;no SNOMED codes identified 48 S WVPIEN=$$PAPIEN^WVRPCPR() 49 Q:'WVPIEN 50 S WVIEN=$O(^WV(790.08,"B",WVLABAN,0)) 51 Q:'WVIEN 52 S WVNODE=$G(^WV(790.08,WVIEN,0)) 53 Q:WVNODE="" 54 S WVLRDFN=$P(WVNODE,U,36) 55 Q:'WVLRDFN 56 S WVLRI=$P(WVNODE,U,37) 57 Q:'WVLRI 58 S WVLRSS=$P(WVNODE,U,38) 59 S WVDFN=$P(WVNODE,U,2) 60 S WVPROV=$P(WVNODE,U,7) 61 S WVLOC=$P(WVNODE,U,11) 62 S WVDATE=$P(WVNODE,U,12) 63 S WVLABAN=$P(WVNODE,U,1) 64 S WVDUZ2=$P(WVNODE,U,10) 65 I WVLRSS="CY" D Q 66 .S WVPAP=$$CY() 67 .D:WVPAP ADD 68 .Q 69 I WVLRSS="SP" D Q 70 .S WVPAP=$$SP() 71 .D:WVPAP ADD 72 .Q 73 Q 74 ; 75 CODES ; WVTOP array identifies SNOMED codes (IENS) used for pap smears 76 N WVPIEN,WVPIEN1,WVSNOMED 77 S WVTOP(0)=0 78 S WVPIEN=$$PAPIEN^WVRPCPR() 79 I 'WVPIEN Q ;pap smear procedure not identified 80 S WVPIEN1=0 81 F S WVPIEN1=$O(^WV(790.2,WVPIEN,2,WVPIEN1)) Q:'WVPIEN1 D 82 .S WVSNOMED=$P($G(^WV(790.2,WVPIEN,2,WVPIEN1,0)),U,1) 83 .Q:'WVSNOMED 84 .S WVTOP(0)=WVTOP(0)+1 85 .S WVTOP(WVSNOMED)="" 86 .Q 87 Q 88 CY() ; Check SNOMED codes used by cytology entry 89 N WVFLAG,WVLOOP,WVSNOMED 90 S (WVFLAG,WVLOOP)=0 91 ; check topography multiple 92 F S WVLOOP=$O(^LR(WVLRDFN,"CY",WVLRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1) D 93 .S WVSNOMED=+$P($G(^LR(WVLRDFN,"CY",WVLRI,2,WVLOOP,0)),U,1) 94 .Q:'WVSNOMED 95 .I $D(WVTOP(WVSNOMED)) S WVFLAG=1 96 .Q 97 Q WVFLAG 98 ; 99 SP() ; Check SNOMED codes used by surgical pathology entry 100 N WVFLAG,WVLOOP,WVSNOMED 101 ; check topography multiple 102 S (WVFLAG,WVLOOP)=0 103 F S WVLOOP=$O(^LR(WVLRDFN,"SP",WVLRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1) D 104 .S WVSNOMED=+$P($G(^LR(WVLRDFN,"SP",WVLRI,2,WVLOOP,0)),U,1) 105 .Q:'WVSNOMED 106 .I $D(WVTOP(WVSNOMED)) S WVFLAG=1 107 .Q 108 Q WVFLAG 109 ; 110 ADD ; Add pap smear to FILE 790.1 111 N WVDR,WVERR 112 S WVERR=0 113 I '$D(^WV(790,WVDFN,0)) D ;add patient to File 790, if not there 114 .D AUTOADD^WVPATE(WVDFN,WVDUZ2,.WVERR) 115 .Q 116 Q:WVERR<0 ;quit if new patient could not be added to File 790 117 S WVDR=".02////"_WVDFN 118 S WVDR=WVDR_";.04////"_WVPIEN ;File 790.2 pointer 119 S:WVPROV]"" WVDR=WVDR_";.07////"_WVPROV ;provider 120 S WVDR=WVDR_";.1////"_WVDUZ2 ;health care facility 121 S:WVLOC]"" WVDR=WVDR_";.11////"_WVLOC ;patient location 122 S WVDR=WVDR_";.12////"_WVDATE ;procedure date/time 123 S WVDR=WVDR_";.14////"_"o" ;status 124 S WVDR=WVDR_";.18////.5;.19////"_DT ;entering user and date 125 S WVDR=WVDR_";.34////"_WVDUZ2 ;accessioning facility 126 S WVDR=WVDR_";2.17////"_WVLABAN ;lab accession# 127 S WVDR=WVDR_";2.18////"_WVLRDFN ;Lab Data file (#63) pointer 128 S WVDR=WVDR_";2.19////"_WVLRI ;Lab Data file inverse d/t 129 S WVDR=WVDR_";2.2////"_WVLRSS ;Lab Data file subscript (CY/SP) 130 ; add procedure to File 790.1 131 D NEW2^WVPROC(WVDFN,WVPIEN,WVDATE,WVDR,"","",.WVERR) 132 Q:'Y 133 I $$PATCH^XPDUTL("OR*3.0*210") D 134 .D CPRS^WVSNOMED(70,WVDFN,"",WVPROV,"Pap Smear results available.","") 135 .D DELETE^WVLABADD(WVIEN) 136 .Q 137 Q -
WorldVistAEHR/trunk/r/WOMENS_HEALTH-WV/WVRALINK.m
r613 r623 1 WVRALINK ;HCIOFO/FT-RAD/NM-WOMEN'S HEALTH LINK ;6/10/04 14:51 2 ;;1.0;WOMEN'S HEALTH;**3,5,7,9,10,16,18,23**;Sep 30, 1998;Build 5 3 ; 4 ; This routine uses the following IAs: 5 ; #2480 - FILE 70 (private) 6 ; #2481 - FILE 71 (private) 7 ; #2482 - FILE 71.2 (private) 8 ; #10035 - FILE 2 (supported) 9 ; #10063 - ^%ZTLOAD (supported) 10 ; #10070 - ^XMD (supported) 11 ; #10141 - ^XPDUTL (supported) 12 ; #2541 - ^XUPARAM (supported) 13 ; 14 ;; Original routine created by IHS/ANMC/MWR 15 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER * 16 ;; CREATE MAMMOGRAM PROCEDURE IN WOMEN'S HEALTH FOR THIS PATIENT. 17 ;; CALLED BY ^RART WHEN A RADIOLOGY REPORT IS VERIFIED. 18 ;; CALLED BY ^RARTE1 WHEN A RADIOLOGY REPORT IS UNVERIFIED. 19 ;; CALLED BY ^WVEXPTRA WHEN EXPORTING HISTORICAL MAMS TO WOMEN'S HEALTH 20 ; 21 ;---> REQUIRED VARIABLES: DFN = DFN OF RADIOLOGY PATIENT. 22 ;---> DATE = INVERSE DATE/TIME OF VISIT. 23 ;---> CASE = IEN OF RADIOLOGY EXAM (CASE). 24 ; 25 ;---> OPTIONAL VARIABLE: WVNEWP = TOTAL NEW WH PATIENTS ADDED. 26 ;---> WVMCNT = TOTAL NEW MAMS PROCEDURES ADDED. 27 ;---> THESE IF CALLED FROM ^WVEXPTRA ROUTINE. 28 ; 29 ;---> GENERATED VARIBLES: 30 ;---> WVPROC = IEN OF RADIOLOGY PROCEDURE (FILE #71), THEN IT 31 ;---> GETS CHANGED TO WOMEN'S HEALTH PROCEDURE TYPE 32 ;---> (FILE #790.2). 33 ;---> WVLOC = WARD/CLINIC/LOCATION (FILE #44). 34 ;---> WVDATE = DATE OF THE PROCEDURE. 35 ;---> WVPROV = ORDERING PROVIDER. 36 ;---> WVMOD = LEFT OR RIGHT, IF IT'S A UNILATERAL MAMMOGRAM. 37 ;---> WVDX = RADIOLOGY DIAGNOSTIC CODE. 38 ;---> WVBWDX = WOMEN'S HEALTH RESULT/DIAGNOSIS. 39 ; 40 CREATE(DFN,DATE,CASE) ; 41 Q:'+$$VERSION^XPDUTL("WV") 42 Q:($G(DFN)']"")!($G(DATE)']"")!($G(CASE)']"") 43 N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE 44 S:'$D(DUZ)#2 DUZ=.5 45 S:'$D(DUZ(2))#2 DUZ(2)=$$KSP^XUPARAM("INST") 46 S ZTRTN="CREATEQ^WVRALINK",ZTDESC="WV CREATE MAMMOGRAM ENTRY" 47 S ZTSAVE("DFN")="",ZTSAVE("DATE")="",ZTSAVE("CASE")="" 48 S ZTIO="",ZTDTH=$H 49 D ^%ZTLOAD 50 Q 51 CREATEH(DFN,DATE,CASE,STATUS) ; Entry from ^WVEXPTRA which looks for exams 52 ; created before the WH package was installed. 53 Q:($G(DFN)']"")!($G(DATE)']"")!($G(CASE)']"")!($G(STATUS)']"") 54 ; 55 CREATEQ ; Queue data entry creation. Called from CREATE above 56 N WVPROC,WVLOC,WVDATE,WVDR,WVPROV,WVMOD,WVDX,WVBWDX,WVLEFT,WVRIGHT 57 N WVCASE,WVCPT,WVERR,WVCREDIT,WVEXAM0,WVZSTAT 58 ;---> QUIT IF RADIOLOGY DATA IS NOT DEFINED OR ="". 59 I $D(ZTQUEUED) S ZTREQ="@" 60 Q:'$D(^RADPT(DFN,"DT",DATE,"P",CASE,0)) 61 ; 62 ;---> QUIT IF THIS PROCEDURE DOES NOT HAVE A MAM CPT CODE. 63 ;---> QUIT IF THIS PROCEDURE DOES NOT HAVE AN ULTRASOUND CPT CODE. 64 ;---> WVEXAM0=ZERO NODE OF RADIOLOGY EXAM. 65 S WVEXAM0=^RADPT(DFN,"DT",DATE,"P",CASE,0) 66 S WVCPT=$$GET1^DIQ(71,$P(WVEXAM0,U,2),9,"I") Q:WVCPT="" 67 S WVPROC=$O(^WV(790.2,"AC",WVCPT,0)) ;cpt code x-ref to get 790.2 ien 68 Q:'WVPROC ;cpt code is not tracked in 790.2 69 Q:$P($G(^WV(790.2,+WVPROC,0)),U,5)'="R" ;cpt is not rad/nm procedure 70 Q:$P($G(^DPT(DFN,0)),U,2)'="F" ;not female 71 ; 72 ;---> QUIT IF NO WOMEN'S HEALTH SITE PARAMETER FILE ON THIS MACHINE. 73 ; OR NO DEFAULT CASE MANAGER 74 Q:'$D(^WV(790.02,DUZ(2))) 75 Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,2) 76 ; 77 ;---> IF NOT CALLED FROM ^WVEXPTRA (i.e., STATUS is undefined) CHECK 78 ;---> SITE PARAMETER AND QUIT IF "IMPORT MAMMOGRAMS FROM RADIOLOGY" 79 ;---> IS NOT SET TO "YES". CHECK VETERAN STATUS AND ELIGIBILITY CODE. 80 N Y S Y=^WV(790.02,DUZ(2),0) 81 I '$D(STATUS) Q:'$P(Y,U,10) 82 I '$D(STATUS) Q:'$$VNVEC^WVRALIN1() ;vet/non-vet/eligibility code check 83 ; 84 ;---> SET WVZSTAT =THE STATUS (OPEN OR CLOSED) IN WOMEN'S HEALTH. 85 ;---> THAT MAMMOGRAMS SHOULD RECEIVE WHEN COPIED OVER FROM RADIOLOGY. 86 S WVZSTAT=$P(Y,U,23) S:WVZSTAT="" WVZSTAT="o" 87 I $G(STATUS)]"" S WVZSTAT=$G(STATUS) ;status selected in ^WVEXPTRA 88 ; 89 D COPY(WVEXAM0) 90 ; 91 EXIT ;EP 92 K I,N,X 93 Q 94 ; 95 COPY(Y) ;EP 96 ;---> COPY MAM PROCEDURE DATA FROM RADIOLOGY TO WOMEN'S HEALTH. 97 ;---> VARIABLE DFN=PATIENT 98 ;---> LOCATION=DUZ(2) 99 ;---> WARD/CLINIC/LOCATION 100 N X 101 S WVLOC=$P(Y,U,8) 102 ; 103 ;---> WVDATE=DATE OF THE PROCEDURE. 104 S WVDATE=$P($P(^RADPT(DFN,"DT",DATE,0),U),".") 105 ; 106 ;---> RECONSTRUCT THE FULL CASE# FOR THIS RAD PROCEDURE. 107 ;---> THIS IS USED AS A LINK (XREF) BETWEEN THE RADIOLOGY PROCEDURE 108 ;---> AND THE WOMEN'S HEALTH PROCEDURE. 109 S WVCASE=$E(WVDATE,4,7)_$E(WVDATE,2,3)_"-"_$P(Y,U) 110 ;---> CHECK TO BE SURE THE CASE# XREF IS REALLY DOWN THERE. 111 S:'$D(^RADPT("ADC",WVCASE,DFN,DATE,CASE)) WVCASE="UNKNOWN" 112 ; 113 ;---> QUIT IF THIS PROCEDURE HAS ALREADY BEEN SENT TO WOMEN'S HEALTH. 114 Q:$D(^WV(790.1,"E",WVCASE)) 115 ; 116 ;---> REQUESTING PROVIDER/ORDERING PROVIDER 117 S WVPROV=$P(Y,U,14) 118 ; 119 ;---> IF UNILATERAL, ATTEMPT TO PICK UP LEFT OR RIGHT MODIFIER. 120 I WVPROC=26 D 121 .I $D(^RADPT(DFN,"DT",DATE,"P",CASE,"M",0)) D 122 ..N N S N=0 123 ..F S N=$O(^RADPT(DFN,"DT",DATE,"P",CASE,"M",N)) Q:'N D 124 ...S WVMOD=$P(^RADPT(DFN,"DT",DATE,"P",CASE,"M",N,0),U) 125 ...S WVMOD=$$GET1^DIQ(71.2,WVMOD,.01,"I") 126 ...I "LEFTleft"[WVMOD S WVLEFT=1 127 ...I "RIGHTright"[WVMOD S WVRIGHT=1 128 ..Q:$D(WVLEFT)&($D(WVRIGHT)) 129 ..I $D(WVLEFT) S WVMOD="l" Q 130 ..I $D(WVRIGHT) S WVMOD="r" Q 131 ; 132 ;---> IF THERE'S A DIAGNOSTIC CODE, ATTEMPT TO PICK UP DIAGNOSIS. 133 ;---> USE "WV DIAGNOSTIC CODE TRANSLATION" FILE #790.32. 134 S WVDX=$P(Y,U,13) 135 I +WVDX I $D(^WV(790.32,"C",WVDX)) S WVBWDX=$O(^WV(790.32,"C",WVDX,0)) 136 ; 137 ;---> GET CREDIT METHOD. 138 S WVCREDIT=$P(Y,U,26) 139 ; 140 PATIENT ;---> IF PATIENT ISN'T IN WOMEN'S HEALTH DATABASE, ADD HER. 141 S WVERR=1 142 I '$D(^WV(790,DFN,0)) D 143 .D AUTOADD^WVPATE(DFN,DUZ(2),.WVERR) 144 .I $D(WVNEWP) S:WVERR WVNEWP=WVNEWP+1 145 Q:WVERR<0 146 D FIND^WVRALIN1 ;check for 'unlinked' entry in File 790.1 147 Q:$D(^WV(790.1,"E",WVCASE)) ;quit if link was made in WVRALIN1 148 PROC ;---> CREATE MAMMOGRAM PROCEDURE IN WV PROCEDURE FILE #790.1. 149 S WVDR=".02////"_DFN_";.04////"_WVPROC 150 S WVDR=WVDR_";.05////"_$G(WVBWDX)_";.07////"_WVPROV 151 S WVDR=WVDR_";.09////"_$G(WVMOD)_";.1////"_DUZ(2)_";.11////"_WVLOC 152 S WVDR=WVDR_";.12////"_WVDATE_";.14////"_WVZSTAT_";.15////"_WVCASE 153 S WVDR=WVDR_";.18////.5;.19////"_DT_";.34////"_$G(DUZ(2))_";.35////"_WVCREDIT 154 ; 155 D NEW2^WVPROC(DFN,WVPROC,WVDATE,WVDR,"","",.WVERR) 156 I $D(WVMCNT) S:WVERR>-1 WVMCNT=WVMCNT+1 157 Q:WVERR<0 ;procedure not added 158 Q:$D(WVMCNT) ;mass import of Rad/NM exams 159 ;Q:$P($G(^WV(790.02,+DUZ(2),0)),U,23)="c" ;Status=closed 160 I (WVCPT=76856)!(WVCPT=76830)!(WVCPT=76645) D Q ;not breast related 161 .D MAIL^WVRADWP(DFN,+Y,WVPROC,WVPROV) ;iens for patient, accession, procedure, provider/requestor 162 .Q 163 D CPRS^WVSNOMED(69,DFN,"",WVPROV,"Mammogram results available.",DATE_"~"_CASE) 164 Q 165 ; 166 DELETE(DFN,DATE,CASE) ;EP 167 ;---> MODIFY WOMEN'S HEALTH PROCEDURE TO REFLECT CHANGE. 168 ;---> CALLED FROM RARTE1 (DELETE A REPORT AND UNVERIFY A REPORT). 169 ; 170 Q:'+$$VERSION^XPDUTL("WV") 171 Q:'$D(DFN)!('$D(DATE))!('$D(CASE)) 172 N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE 173 S ZTRTN="DELETEQ^WVRALINK",ZTDESC="WV MAMMOGRAM RPT CHANGE" 174 S ZTSAVE("DFN")="",ZTSAVE("DATE")="",ZTSAVE("CASE")="" 175 S ZTIO="",ZTDTH=$H 176 D ^%ZTLOAD 177 Q 178 DELETEQ ; Modify WV entry when mammogram report is unverified or deleted 179 Q:'$D(^RADPT(DFN,"DT",DATE,"P",CASE,0)) 180 N WVIEN,WVDATE,WVCASE,WVCMGR,WVLOOP,WVMSG,WVPROV 181 N XMDUZ,XMSUB,XMTEXT,XMY ;send mail message to case manager 182 I $D(ZTQUEUED) S ZTREQ="@" 183 ; 184 ;---> WVDATE=DATE OF PROCEDURE. 185 S WVDATE=$P($P(^RADPT(DFN,"DT",DATE,0),U),".") 186 S WVCASE=$P(^RADPT(DFN,"DT",DATE,"P",CASE,0),U) 187 ; 188 ;---> WVCASE=RECONSTRUCTED CASE# OF PROCEDURE. 189 S WVCASE=$E(WVDATE,4,7)_$E(WVDATE,2,3)_"-"_WVCASE 190 ;---> QUIT IF NO CASE# XREF IN WOMEN'S HEALTH PROCEDURE FILE. 191 Q:'$D(^WV(790.1,"E",WVCASE)) 192 ; 193 S WVIEN=$O(^WV(790.1,"E",WVCASE,0)) 194 Q:'$D(^WV(790.1,WVIEN,0)) 195 D RADMOD^WVPROC(WVIEN) ;update wh status to "open" 196 S WVPROV=+$$GET1^DIQ(790.1,WVIEN,.07,"I") ;get provider/requestor 197 S WVCMGR=+$$GET1^DIQ(790,DFN,.1,"I") ;get case manager 198 S:WVCMGR XMY(WVCMGR)="" 199 ; if no case manager, then get default case manager(s) 200 I 'WVCMGR S WVLOOP=0 F S WVLOOP=$O(^WV(790.02,WVLOOP)) Q:'WVLOOP D 201 .S WVCMGR=$$GET1^DIQ(790.02,WVLOOP,.02,"I") 202 .S:WVCMGR XMY(WVCMGR)="" 203 .Q 204 Q:$O(XMY(0))'>0 ;no case manager(s) 205 S:WVPROV XMY(WVPROV)="" 206 S XMDUZ=.5 ;message sender 207 S XMSUB="RAD/NM Rpt for WH patient is UNVERIFIED/DELETED" 208 S WVMSG(1)=" Patient: "_$P($G(^DPT(DFN,0)),U,1)_" (SSN: "_$$SSN^WVUTL1(DFN)_")" 209 S WVMSG(2)=" WH Accession #: "_$P($G(^WV(790.1,+WVIEN,0)),U,1) 210 S WVMSG(3)=" RAD/NM Case #: "_WVCASE 211 S WVMSG(4)=" " 212 S WVMSG(5)="NOTE: THIS PROCEDURE HAS BEEN ALTERED IN RADIOLOGY/NM." 213 S WVMSG(6)="Follow-up is required in the WOMEN'S HEALTH package!" 214 S XMTEXT="WVMSG(" 215 D ^XMD 216 Q 1 WVRALINK ;HCIOFO/FT-RAD/NM-WOMEN'S HEALTH LINK ;6/10/04 14:51 2 ;;1.0;WOMEN'S HEALTH;**3,5,7,9,10,16,18**;Sep 30, 1998 3 ; 4 ; This routine uses the following IAs: 5 ; #2480 - FILE 70 (private) 6 ; #2481 - FILE 71 (private) 7 ; #2482 - FILE 71.2 (private) 8 ; #10035 - FILE 2 (supported) 9 ; #10063 - ^%ZTLOAD (supported) 10 ; #10070 - ^XMD (supported) 11 ; #10141 - ^XPDUTL (supported) 12 ; 13 ;; Original routine created by IHS/ANMC/MWR 14 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER * 15 ;; CREATE MAMMOGRAM PROCEDURE IN WOMEN'S HEALTH FOR THIS PATIENT. 16 ;; CALLED BY ^RART WHEN A RADIOLOGY REPORT IS VERIFIED. 17 ;; CALLED BY ^RARTE1 WHEN A RADIOLOGY REPORT IS UNVERIFIED. 18 ;; CALLED BY ^WVEXPTRA WHEN EXPORTING HISTORICAL MAMS TO WOMEN'S HEALTH 19 ; 20 ;---> REQUIRED VARIABLES: DFN = DFN OF RADIOLOGY PATIENT. 21 ;---> DATE = INVERSE DATE/TIME OF VISIT. 22 ;---> CASE = IEN OF RADIOLOGY EXAM (CASE). 23 ; 24 ;---> OPTIONAL VARIABLE: WVNEWP = TOTAL NEW WH PATIENTS ADDED. 25 ;---> WVMCNT = TOTAL NEW MAMS PROCEDURES ADDED. 26 ;---> THESE IF CALLED FROM ^WVEXPTRA ROUTINE. 27 ; 28 ;---> GENERATED VARIBLES: 29 ;---> WVPROC = IEN OF RADIOLOGY PROCEDURE (FILE #71), THEN IT 30 ;---> GETS CHANGED TO WOMEN'S HEALTH PROCEDURE TYPE 31 ;---> (FILE #790.2). 32 ;---> WVLOC = WARD/CLINIC/LOCATION (FILE #44). 33 ;---> WVDATE = DATE OF THE PROCEDURE. 34 ;---> WVPROV = ORDERING PROVIDER. 35 ;---> WVMOD = LEFT OR RIGHT, IF IT'S A UNILATERAL MAMMOGRAM. 36 ;---> WVDX = RADIOLOGY DIAGNOSTIC CODE. 37 ;---> WVBWDX = WOMEN'S HEALTH RESULT/DIAGNOSIS. 38 ; 39 CREATE(DFN,DATE,CASE) ; 40 Q:'+$$VERSION^XPDUTL("WV") 41 Q:($G(DFN)']"")!($G(DATE)']"")!($G(CASE)']"") 42 N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE 43 S:'$D(DUZ)#2 DUZ=.5 44 S:'$D(DUZ(2))#2 DUZ(2)=$$KSP^XUPARAM("INST") 45 S ZTRTN="CREATEQ^WVRALINK",ZTDESC="WV CREATE MAMMOGRAM ENTRY" 46 S ZTSAVE("DFN")="",ZTSAVE("DATE")="",ZTSAVE("CASE")="" 47 S ZTIO="",ZTDTH=$H 48 D ^%ZTLOAD 49 Q 50 CREATEH(DFN,DATE,CASE,STATUS) ; Entry from ^WVEXPTRA which looks for exams 51 ; created before the WH package was installed. 52 Q:($G(DFN)']"")!($G(DATE)']"")!($G(CASE)']"")!($G(STATUS)']"") 53 ; 54 CREATEQ ; Queue data entry creation. Called from CREATE above 55 N WVPROC,WVLOC,WVDATE,WVDR,WVPROV,WVMOD,WVDX,WVBWDX,WVLEFT,WVRIGHT 56 N WVCASE,WVCPT,WVERR,WVCREDIT,WVEXAM0,WVZSTAT 57 ;---> QUIT IF RADIOLOGY DATA IS NOT DEFINED OR ="". 58 I $D(ZTQUEUED) S ZTREQ="@" 59 Q:'$D(^RADPT(DFN,"DT",DATE,"P",CASE,0)) 60 ; 61 ;---> QUIT IF THIS PROCEDURE DOES NOT HAVE A MAM CPT CODE. 62 ;---> QUIT IF THIS PROCEDURE DOES NOT HAVE AN ULTRASOUND CPT CODE. 63 ;---> WVEXAM0=ZERO NODE OF RADIOLOGY EXAM. 64 S WVEXAM0=^RADPT(DFN,"DT",DATE,"P",CASE,0) 65 S WVCPT=$$GET1^DIQ(71,$P(WVEXAM0,U,2),9,"I") Q:WVCPT="" 66 S WVPROC=$O(^WV(790.2,"AC",WVCPT,0)) ;cpt code x-ref to get 790.2 ien 67 Q:'WVPROC ;cpt code is not tracked in 790.2 68 Q:$P($G(^WV(790.2,+WVPROC,0)),U,5)'="R" ;cpt is not rad/nm procedure 69 Q:$P($G(^DPT(DFN,0)),U,2)'="F" ;not female 70 ; 71 ;---> QUIT IF NO WOMEN'S HEALTH SITE PARAMETER FILE ON THIS MACHINE. 72 ; OR NO DEFAULT CASE MANAGER 73 Q:'$D(^WV(790.02,DUZ(2))) 74 Q:'$P($G(^WV(790.02,+$G(DUZ(2)),0)),U,2) 75 ; 76 ;---> IF NOT CALLED FROM ^WVEXPTRA (i.e., STATUS is undefined) CHECK 77 ;---> SITE PARAMETER AND QUIT IF "IMPORT MAMMOGRAMS FROM RADIOLOGY" 78 ;---> IS NOT SET TO "YES". CHECK VETERAN STATUS AND ELIGIBILITY CODE. 79 N Y S Y=^WV(790.02,DUZ(2),0) 80 I '$D(STATUS) Q:'$P(Y,U,10) 81 I '$D(STATUS) Q:'$$VNVEC^WVRALIN1() ;vet/non-vet/eligibility code check 82 ; 83 ;---> SET WVZSTAT =THE STATUS (OPEN OR CLOSED) IN WOMEN'S HEALTH. 84 ;---> THAT MAMMOGRAMS SHOULD RECEIVE WHEN COPIED OVER FROM RADIOLOGY. 85 S WVZSTAT=$P(Y,U,23) S:WVZSTAT="" WVZSTAT="o" 86 I $G(STATUS)]"" S WVZSTAT=$G(STATUS) ;status selected in ^WVEXPTRA 87 ; 88 D COPY(WVEXAM0) 89 ; 90 EXIT ;EP 91 K I,N,X 92 Q 93 ; 94 COPY(Y) ;EP 95 ;---> COPY MAM PROCEDURE DATA FROM RADIOLOGY TO WOMEN'S HEALTH. 96 ;---> VARIABLE DFN=PATIENT 97 ;---> LOCATION=DUZ(2) 98 ;---> WARD/CLINIC/LOCATION 99 N X 100 S WVLOC=$P(Y,U,8) 101 ; 102 ;---> WVDATE=DATE OF THE PROCEDURE. 103 S WVDATE=$P($P(^RADPT(DFN,"DT",DATE,0),U),".") 104 ; 105 ;---> RECONSTRUCT THE FULL CASE# FOR THIS RAD PROCEDURE. 106 ;---> THIS IS USED AS A LINK (XREF) BETWEEN THE RADIOLOGY PROCEDURE 107 ;---> AND THE WOMEN'S HEALTH PROCEDURE. 108 S WVCASE=$E(WVDATE,4,7)_$E(WVDATE,2,3)_"-"_$P(Y,U) 109 ;---> CHECK TO BE SURE THE CASE# XREF IS REALLY DOWN THERE. 110 S:'$D(^RADPT("ADC",WVCASE,DFN,DATE,CASE)) WVCASE="UNKNOWN" 111 ; 112 ;---> QUIT IF THIS PROCEDURE HAS ALREADY BEEN SENT TO WOMEN'S HEALTH. 113 Q:$D(^WV(790.1,"E",WVCASE)) 114 ; 115 ;---> REQUESTING PROVIDER/ORDERING PROVIDER 116 S WVPROV=$P(Y,U,14) 117 ; 118 ;---> IF UNILATERAL, ATTEMPT TO PICK UP LEFT OR RIGHT MODIFIER. 119 I WVPROC=26 D 120 .I $D(^RADPT(DFN,"DT",DATE,"P",CASE,"M",0)) D 121 ..N N S N=0 122 ..F S N=$O(^RADPT(DFN,"DT",DATE,"P",CASE,"M",N)) Q:'N D 123 ...S WVMOD=$P(^RADPT(DFN,"DT",DATE,"P",CASE,"M",N,0),U) 124 ...S WVMOD=$$GET1^DIQ(71.2,WVMOD,.01,"I") 125 ...I "LEFTleft"[WVMOD S WVLEFT=1 126 ...I "RIGHTright"[WVMOD S WVRIGHT=1 127 ..Q:$D(WVLEFT)&($D(WVRIGHT)) 128 ..I $D(WVLEFT) S WVMOD="l" Q 129 ..I $D(WVRIGHT) S WVMOD="r" Q 130 ; 131 ;---> IF THERE'S A DIAGNOSTIC CODE, ATTEMPT TO PICK UP DIAGNOSIS. 132 ;---> USE "WV DIAGNOSTIC CODE TRANSLATION" FILE #790.32. 133 S WVDX=$P(Y,U,13) 134 I +WVDX I $D(^WV(790.32,"C",WVDX)) S WVBWDX=$O(^WV(790.32,"C",WVDX,0)) 135 ; 136 ;---> GET CREDIT METHOD. 137 S WVCREDIT=$P(Y,U,26) 138 ; 139 PATIENT ;---> IF PATIENT ISN'T IN WOMEN'S HEALTH DATABASE, ADD HER. 140 S WVERR=1 141 I '$D(^WV(790,DFN,0)) D 142 .D AUTOADD^WVPATE(DFN,DUZ(2),.WVERR) 143 .I $D(WVNEWP) S:WVERR WVNEWP=WVNEWP+1 144 Q:WVERR<0 145 D FIND^WVRALIN1 ;check for 'unlinked' entry in File 790.1 146 Q:$D(^WV(790.1,"E",WVCASE)) ;quit if link was made in WVRALIN1 147 PROC ;---> CREATE MAMMOGRAM PROCEDURE IN WV PROCEDURE FILE #790.1. 148 S WVDR=".02////"_DFN_";.04////"_WVPROC 149 S WVDR=WVDR_";.05////"_$G(WVBWDX)_";.07////"_WVPROV 150 S WVDR=WVDR_";.09////"_$G(WVMOD)_";.1////"_DUZ(2)_";.11////"_WVLOC 151 S WVDR=WVDR_";.12////"_WVDATE_";.14////"_WVZSTAT_";.15////"_WVCASE 152 S WVDR=WVDR_";.18////.5;.19////"_DT_";.34////"_$G(DUZ(2))_";.35////"_WVCREDIT 153 ; 154 D NEW2^WVPROC(DFN,WVPROC,WVDATE,WVDR,"","",.WVERR) 155 I $D(WVMCNT) S:WVERR>-1 WVMCNT=WVMCNT+1 156 Q:WVERR<0 ;procedure not added 157 Q:$D(WVMCNT) ;mass import of Rad/NM exams 158 ;Q:$P($G(^WV(790.02,+DUZ(2),0)),U,23)="c" ;Status=closed 159 I (WVCPT=76856)!(WVCPT=76830)!(WVCPT=76645) D Q ;not breast related 160 .D MAIL^WVRADWP(DFN,+Y,WVPROC,WVPROV) ;iens for patient, accession, procedure, provider/requestor 161 .Q 162 D CPRS^WVSNOMED(69,DFN,"",WVPROV,"Mammogram results available.","") 163 Q 164 ; 165 DELETE(DFN,DATE,CASE) ;EP 166 ;---> MODIFY WOMEN'S HEALTH PROCEDURE TO REFLECT CHANGE. 167 ;---> CALLED FROM RARTE1 (DELETE A REPORT AND UNVERIFY A REPORT). 168 ; 169 Q:'+$$VERSION^XPDUTL("WV") 170 Q:'$D(DFN)!('$D(DATE))!('$D(CASE)) 171 N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE 172 S ZTRTN="DELETEQ^WVRALINK",ZTDESC="WV MAMMOGRAM RPT CHANGE" 173 S ZTSAVE("DFN")="",ZTSAVE("DATE")="",ZTSAVE("CASE")="" 174 S ZTIO="",ZTDTH=$H 175 D ^%ZTLOAD 176 Q 177 DELETEQ ; Modify WV entry when mammogram report is unverified or deleted 178 Q:'$D(^RADPT(DFN,"DT",DATE,"P",CASE,0)) 179 N WVIEN,WVDATE,WVCASE,WVCMGR,WVLOOP,WVMSG,WVPROV 180 N XMDUZ,XMSUB,XMTEXT,XMY ;send mail message to case manager 181 I $D(ZTQUEUED) S ZTREQ="@" 182 ; 183 ;---> WVDATE=DATE OF PROCEDURE. 184 S WVDATE=$P($P(^RADPT(DFN,"DT",DATE,0),U),".") 185 S WVCASE=$P(^RADPT(DFN,"DT",DATE,"P",CASE,0),U) 186 ; 187 ;---> WVCASE=RECONSTRUCTED CASE# OF PROCEDURE. 188 S WVCASE=$E(WVDATE,4,7)_$E(WVDATE,2,3)_"-"_WVCASE 189 ;---> QUIT IF NO CASE# XREF IN WOMEN'S HEALTH PROCEDURE FILE. 190 Q:'$D(^WV(790.1,"E",WVCASE)) 191 ; 192 S WVIEN=$O(^WV(790.1,"E",WVCASE,0)) 193 Q:'$D(^WV(790.1,WVIEN,0)) 194 D RADMOD^WVPROC(WVIEN) ;update wh status to "open" 195 S WVPROV=+$$GET1^DIQ(790.1,WVIEN,.07,"I") ;get provider/requestor 196 S WVCMGR=+$$GET1^DIQ(790,DFN,.1,"I") ;get case manager 197 S:WVCMGR XMY(WVCMGR)="" 198 ; if no case manager, then get default case manager(s) 199 I 'WVCMGR S WVLOOP=0 F S WVLOOP=$O(^WV(790.02,WVLOOP)) Q:'WVLOOP D 200 .S WVCMGR=$$GET1^DIQ(790.02,WVLOOP,.02,"I") 201 .S:WVCMGR XMY(WVCMGR)="" 202 .Q 203 Q:$O(XMY(0))'>0 ;no case manager(s) 204 S:WVPROV XMY(WVPROV)="" 205 S XMDUZ=.5 ;message sender 206 S XMSUB="RAD/NM Rpt for WH patient is UNVERIFIED/DELETED" 207 S WVMSG(1)=" Patient: "_$P($G(^DPT(DFN,0)),U,1)_" (SSN: "_$$SSN^WVUTL1(DFN)_")" 208 S WVMSG(2)=" WH Accession #: "_$P($G(^WV(790.1,+WVIEN,0)),U,1) 209 S WVMSG(3)=" RAD/NM Case #: "_WVCASE 210 S WVMSG(4)=" " 211 S WVMSG(5)="NOTE: THIS PROCEDURE HAS BEEN ALTERED IN RADIOLOGY/NM." 212 S WVMSG(6)="Follow-up is required in the WOMEN'S HEALTH package!" 213 S XMTEXT="WVMSG(" 214 D ^XMD 215 Q -
WorldVistAEHR/trunk/r/WOMENS_HEALTH-WV/WVSNOMED.m
r613 r623 1 WVSNOMED 2 ;;1.0;WOMEN'S HEALTH;**16,23**;Sep 30, 1998;Build 5 3 4 5 6 7 8 9 10 11 12 SNOMED() 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 CY() 37 38 39 40 41 42 43 44 45 46 47 SP() 48 49 50 51 52 53 54 55 56 57 58 ADD 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 .D CPRS^WVSNOMED(70,DFN,"",WVPROV,"Pap Smear results available.",LRSS_U_WVLABAN_U_LRI)85 86 87 88 MAIL(DFN,WVLABAN,WVPROV,LRSS,WV7901) 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 CPRS(WVORN,WVDFN,WVORDER,WVPROV,WVMSG,WVIEN) 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 1 WVSNOMED ;HIOFO/FT-IS LAB TEST A PAP SMEAR? ;2/12/04 14:37 2 ;;1.0;WOMEN'S HEALTH;**16**;Sep 30, 1998 3 ; 4 ; This routine uses the following IAs: 5 ; #1362 - ^ORB3 (controlled) 6 ; #525 - ^LR references (controlled) 7 ; #4298 - ^LR references (private) 8 ; #10035 - ^DPT( references (supported) 9 ; #10070 - ^XMD (supported) 10 ; #10141 - ^XPDUTL (supported) 11 ; 12 SNOMED() ; Check lab test for SNOMED codes that indicate if pap smear. 13 ; LRDFN,LRI,LRSS must be defined. 14 ; Returns: 0 - lab test is not a pap smear 15 ; 1 - lab test is a pap smear 16 ; 17 N WVPAP,WVPIEN,WVPIEN1,WVSNOMED,WVTOP 18 ; WVTOP array identifies SNOMED codes (IENS) used for pap smears 19 S WVTOP(0)=0 20 S WVPIEN=$$PAPIEN^WVRPCPR() 21 I 'WVPIEN Q 0 ;pap smear procedure entry not found 22 S WVPIEN1=0 23 F S WVPIEN1=$O(^WV(790.2,WVPIEN,2,WVPIEN1)) Q:'WVPIEN1 D 24 .S WVSNOMED=$P($G(^WV(790.2,WVPIEN,2,WVPIEN1,0)),U,1) 25 .Q:'WVSNOMED 26 .S WVTOP(0)=WVTOP(0)+1 27 .S WVTOP(WVSNOMED)="" 28 .Q 29 I WVTOP(0)=0 Q 0 ;no SNOMED codes identified 30 K WVTOP(0) 31 S WVPAP=0 32 I LRSS="CY" S WVPAP=$$CY() 33 I LRSS="SP" S WVPAP=$$SP() 34 Q WVPAP 35 ; 36 CY() ; Check SNOMED codes used by cytology entry 37 N WVFLAG,WVLOOP,WVLOOP1,WVSNOMED 38 S (WVFLAG,WVLOOP)=0 39 ; check topography multiple 40 F S WVLOOP=$O(^LR(LRDFN,"CY",LRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1) D 41 .S WVSNOMED=+$P($G(^LR(LRDFN,"CY",LRI,2,WVLOOP,0)),U,1) 42 .Q:'WVSNOMED 43 .I $D(WVTOP(WVSNOMED)) S WVFLAG=1 44 .Q 45 Q WVFLAG 46 ; 47 SP() ; Check SNOMED codes used by surgical pathology entry 48 N WVFLAG,WVLOOP,WVLOOP1,WVSNOMED 49 ; check topography multiple 50 S (WVFLAG,WVLOOP)=0 51 F S WVLOOP=$O(^LR(LRDFN,"SP",LRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1) D 52 .S WVSNOMED=+$P($G(^LR(LRDFN,"SP",LRI,2,WVLOOP,0)),U,1) 53 .Q:'WVSNOMED 54 .I $D(WVTOP(WVSNOMED)) S WVFLAG=1 55 .Q 56 Q WVFLAG 57 ; 58 ADD ; Add pap smear to FILE 790.1 59 N WV7901,WVDR,WVPIEN,WVERR 60 S WVERR=0 61 I '$D(^WV(790,DFN,0)) D ;add patient to File 790, if not there 62 .D AUTOADD^WVPATE(DFN,DUZ(2),.WVERR) 63 .Q 64 Q:WVERR<0 ;quit if new patient could not be added to File 790 65 S WVPIEN=$$PAPIEN^WVRPCPR() 66 S WVDR=".02////"_DFN 67 S WVDR=WVDR_";.04////"_WVPIEN ;File 790.2 pointer 68 S:WVPROV]"" WVDR=WVDR_";.07////"_WVPROV ;provider 69 S WVDR=WVDR_";.1////"_$G(DUZ(2)) ;health care facility 70 S:WVLOC]"" WVDR=WVDR_";.11////"_WVLOC ;patient location 71 S WVDR=WVDR_";.12////"_WVDATE ;procedure date/time 72 S WVDR=WVDR_";.14////"_"o" ;status 73 S WVDR=WVDR_";.18////.5;.19////"_DT ;entering user and date 74 S WVDR=WVDR_";.34////"_$G(DUZ(2)) ;accessioning facility 75 S WVDR=WVDR_";2.17////"_WVLABAN ;lab accession# 76 S WVDR=WVDR_";2.18////"_LRDFN ;Lab Data file (#63) pointer 77 S WVDR=WVDR_";2.19////"_LRI ;Lab Data file inverse d/t 78 S WVDR=WVDR_";2.2////"_LRSS ;Lab Data file subscript (CY/SP) 79 ; add procedure to File 790.1 80 D NEW2^WVPROC(DFN,WVPIEN,WVDATE,WVDR,"","",.WVERR) 81 Q:'Y 82 S WV7901=+Y 83 I $$PATCH^XPDUTL("OR*3.0*210") D Q 84 .D CPRS^WVSNOMED(70,DFN,"",WVPROV,"Pap Smear results available.","") 85 .Q 86 D MAIL(DFN,WVLABAN,WVPROV,LRSS,WV7901) 87 Q 88 MAIL(DFN,WVLABAN,WVPROV,LRSS,WV7901) ; Send mail message to case manager 89 ; when pap smear added to FILE 790.1 90 ; Called from above 91 ; DFN -> Patient ien 92 ; WVLABAN -> Lab Accession# (e.g., CY 99 1) 93 ; WVPROV -> File 200 IEN (provider/requestor) 94 ; LRSS -> File 63 subscript (e.g., CY or SP) 95 ; WV7901 -> FILE 790.1 IEN 96 Q:'$G(DFN)!($G(WVLABAN)="")!($G(LRSS)="") 97 N WVCMGR,WVLOOP,WVMSG,XMDUZ,XMSUB,XMTEXT,XMY 98 S WVCMGR=+$$GET1^DIQ(790,DFN,.1,"I") ;get case manager 99 S:WVCMGR XMY(WVCMGR)="" 100 ; if no case manager, then get default case manager(s) 101 I 'WVCMGR S WVLOOP=0 F S WVLOOP=$O(^WV(790.02,WVLOOP)) Q:'WVLOOP D 102 .S WVCMGR=$$GET1^DIQ(790.02,WVLOOP,.02,"I") 103 .S:WVCMGR XMY(WVCMGR)="" 104 .Q 105 Q:$O(XMY(0))'>0 ;no case manager(s) 106 S XMDUZ=.5 ;message sender 107 S XMSUB="Pap Smear report verified for a WH patient" 108 S WVMSG(1)="A "_$S(LRSS="CY":"Cytology ",LRSS="SP":"Surgical Pathology ",1:"")_"lab test was verified for:" 109 S WVMSG(2)=" " 110 S WVMSG(3)=" Patient: "_$P($G(^DPT(DFN,0)),U,1)_" (SSN: "_$$SSN^WVUTL1(DFN)_")" 111 S WVMSG(4)=" WH Accession #: "_$P($G(^WV(790.1,+WV7901,0)),U,1) 112 S WVMSG(5)=" LAB Accession #: "_WVLABAN 113 S WVMSG(6)="Test Requestor/Provider: "_$S(+WVPROV:$$GET1^DIQ(200,+WVPROV,.01,"E"),1:"UNKNOWN") 114 S WVMSG(7)=" " 115 S WVMSG(8)="Please use CPRS to resolve the Clinical Reminder for this procedure and" 116 S WVMSG(9)="complete the result." 117 S XMTEXT="WVMSG(" 118 D ^XMD 119 Q 120 ; 121 CPRS(WVORN,WVDFN,WVORDER,WVPROV,WVMSG,WVIEN) ; Generate a CPRS alert 122 ; WVORN - FILE 100.9 IEN 123 ; WVDFN - FILE 2 IEN 124 ; WVORDER - FILE 100 IEN (not currently used) 125 ; WVPROV - FILE 200 IEN 126 ; WVMSG - Free text message 127 ; WVIEN - IEN for a lab or radiology report (not currently used) 128 ; 129 Q:'$$PATCH^XPDUTL("OR*3.0*210") ;no pap & mam alerts 130 Q:'WVDFN 131 Q:'WVORN 132 I WVPROV]"" S WVARRAY(WVPROV)="" ;provider's IEN 133 S WVCMGR=$P($G(^WV(790,WVDFN,0)),U,10) 134 I WVCMGR]"" S WVARRAY(WVCMGR)="" ;women's health case manager's IEN 135 D EN^ORB3(WVORN,WVDFN,WVORDER,.WVARRAY,WVMSG,WVIEN) 136 K WVARRAY,WVCMGR 137 Q
Note:
See TracChangeset
for help on using the changeset viewer.
