Changeset 623 for WorldVistAEHR/trunk/r/WOMENS_HEALTH-WV/WVLABCHK.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/WOMENS_HEALTH-WV/WVLABCHK.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
Note:
See TracChangeset
for help on using the changeset viewer.
