Changeset 623 for WorldVistAEHR/trunk/r/WOMENS_HEALTH-WV/WVSNOMED.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/WOMENS_HEALTH-WV/WVSNOMED.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
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.
