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

WVSNOMED.m

Go to the documentation of this file. 
  1. WVSNOMED ;HIOFO/FT-IS LAB TEST A PAP SMEAR? ;2/12/04  14:37
  1.  ;;1.0;WOMEN'S HEALTH;**16,23,25**;Sep 30, 1998;Build 1
  1.  ;
  1.  ; This routine uses the following IAs:
  1.  ;  #1362 - ^ORB3               (controlled)
  1.  ;   #525 - ^LR references      (controlled)
  1.  ;  #4298 - ^LR references      (private)
  1.  ; #10035 - ^DPT( references    (supported)
  1.  ; #10070 - ^XMD                (supported)
  1.  ; #10141 - ^XPDUTL             (supported)
  1.  ;
  1. SNOMED() ; Check lab test for SNOMED codes that indicate if pap smear.
  1.  ; LRDFN,LRI,LRSS must be defined.
  1.  ; Returns: 0 - lab test is not a pap smear
  1.  ;          1 - lab test is a pap smear
  1.  ; 
  1.  N WVPAP,WVPIEN,WVPIEN1,WVSNOMED,WVTOP
  1.  ; WVTOP array identifies SNOMED codes (IENS) used for pap smears
  1.  S WVTOP(0)=0
  1.  S WVPIEN=$$PAPIEN^WVRPCPR()
  1.  I 'WVPIEN Q 0  ;pap smear procedure entry not found
  1.  S WVPIEN1=0
  1.  F  S WVPIEN1=$O(^WV(790.2,WVPIEN,2,WVPIEN1)) Q:'WVPIEN1  D
  1.  .S WVSNOMED=$P($G(^WV(790.2,WVPIEN,2,WVPIEN1,0)),U,1)
  1.  .Q:'WVSNOMED
  1.  .S WVTOP(0)=WVTOP(0)+1
  1.  .S WVTOP(WVSNOMED)=""
  1.  .Q
  1.  I WVTOP(0)=0 Q 0  ;no SNOMED codes identified
  1.  K WVTOP(0)
  1.  S WVPAP=0
  1.  I LRSS="CY" S WVPAP=$$CY()
  1.  I LRSS="SP" S WVPAP=$$SP()
  1.  Q WVPAP
  1.  ;
  1. CY() ; Check SNOMED codes used by cytology entry
  1.  N WVFLAG,WVLOOP,WVLOOP1,WVSNOMED
  1.  S (WVFLAG,WVLOOP)=0
  1.  ; check topography multiple
  1.  F  S WVLOOP=$O(^LR(LRDFN,"CY",LRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1)  D
  1.  .S WVSNOMED=+$P($G(^LR(LRDFN,"CY",LRI,2,WVLOOP,0)),U,1)
  1.  .Q:'WVSNOMED
  1.  .I $D(WVTOP(WVSNOMED)) S WVFLAG=1
  1.  .Q
  1.  Q WVFLAG
  1.  ;
  1. SP() ; Check SNOMED codes used by surgical pathology entry
  1.  N WVFLAG,WVLOOP,WVLOOP1,WVSNOMED
  1.  ; check topography multiple
  1.  S (WVFLAG,WVLOOP)=0
  1.  F  S WVLOOP=$O(^LR(LRDFN,"SP",LRI,2,WVLOOP)) Q:'WVLOOP!(WVFLAG=1)  D
  1.  .S WVSNOMED=+$P($G(^LR(LRDFN,"SP",LRI,2,WVLOOP,0)),U,1)
  1.  .Q:'WVSNOMED
  1.  .I $D(WVTOP(WVSNOMED)) S WVFLAG=1
  1.  .Q
  1.  Q WVFLAG
  1.  ;
  1. ADD ; Add pap smear to FILE 790.1
  1.  N WV7901,WVDR,WVPIEN,WVERR
  1.  S WVERR=0
  1.  I $D(^WV(790.1,"F",WVLABAN)) D  Q
  1.  . I $$PATCH^XPDUTL("OR*3.0*210") D  Q
  1.  ..D CPRS^WVSNOMED(70,DFN,"",WVPROV,"Pap Smear results available.",LRSS_U_WVLABAN_U_LRI)
  1.  I '$D(^WV(790,DFN,0)) D  ;add patient to File 790, if not there
  1.  .D AUTOADD^WVPATE(DFN,DUZ(2),.WVERR)
  1.  .Q
  1.  Q:WVERR<0  ;quit if new patient could not be added to File 790
  1.  S WVPIEN=$$PAPIEN^WVRPCPR()
  1.  S WVDR=".02////"_DFN
  1.  S WVDR=WVDR_";.04////"_WVPIEN ;File 790.2 pointer
  1.  S:WVPROV]"" WVDR=WVDR_";.07////"_WVPROV ;provider
  1.  S WVDR=WVDR_";.1////"_$G(DUZ(2)) ;health care facility
  1.  S:WVLOC]"" WVDR=WVDR_";.11////"_WVLOC ;patient location
  1.  S WVDR=WVDR_";.12////"_WVDATE ;procedure date/time
  1.  S WVDR=WVDR_";.14////"_"o" ;status
  1.  S WVDR=WVDR_";.18////.5;.19////"_DT ;entering user and date
  1.  S WVDR=WVDR_";.34////"_$G(DUZ(2)) ;accessioning facility
  1.  S WVDR=WVDR_";2.17////"_WVLABAN ;lab accession#
  1.  S WVDR=WVDR_";2.18////"_LRDFN ;Lab Data file (#63) pointer
  1.  S WVDR=WVDR_";2.19////"_LRI ;Lab Data file inverse d/t
  1.  S WVDR=WVDR_";2.2////"_LRSS ;Lab Data file subscript (CY/SP)
  1.  ; add procedure to File 790.1
  1.  D NEW2^WVPROC(DFN,WVPIEN,WVDATE,WVDR,"","",.WVERR)
  1.  Q:'Y
  1.  S WV7901=+Y
  1.  I $$PATCH^XPDUTL("OR*3.0*210") D  Q
  1.  .D CPRS^WVSNOMED(70,DFN,"",WVPROV,"Pap Smear results available.",LRSS_U_WVLABAN_U_LRI)
  1.  .Q
  1.  D MAIL(DFN,WVLABAN,WVPROV,LRSS,WV7901)
  1.  Q
  1. MAIL(DFN,WVLABAN,WVPROV,LRSS,WV7901) ; Send mail message to case manager
  1.  ; when pap smear added to FILE 790.1
  1.  ; Called from above
  1.  ;      DFN -> Patient ien
  1.  ;  WVLABAN -> Lab Accession# (e.g., CY 99 1)
  1.  ;   WVPROV -> File 200   IEN (provider/requestor)
  1.  ;     LRSS -> File 63 subscript (e.g., CY or SP)
  1.  ;   WV7901 -> FILE 790.1 IEN
  1.  Q:'$G(DFN)!($G(WVLABAN)="")!($G(LRSS)="")
  1.  N WVCMGR,WVLOOP,WVMSG,XMDUZ,XMSUB,XMTEXT,XMY
  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 XMDUZ=.5 ;message sender
  1.  S XMSUB="Pap Smear report verified for a WH patient"
  1.  S WVMSG(1)="A "_$S(LRSS="CY":"Cytology ",LRSS="SP":"Surgical Pathology ",1:"")_"lab test was verified for:"
  1.  S WVMSG(2)=" "
  1.  S WVMSG(3)="                Patient: "_$P($G(^DPT(DFN,0)),U,1)_" (SSN: "_$$SSN^WVUTL1(DFN)_")"
  1.  S WVMSG(4)="         WH Accession #: "_$P($G(^WV(790.1,+WV7901,0)),U,1)
  1.  S WVMSG(5)="        LAB Accession #: "_WVLABAN
  1.  S WVMSG(6)="Test Requestor/Provider: "_$S(+WVPROV:$$GET1^DIQ(200,+WVPROV,.01,"E"),1:"UNKNOWN")
  1.  S WVMSG(7)=" "
  1.  S WVMSG(8)="Please use CPRS to resolve the Clinical Reminder for this procedure and"
  1.  S WVMSG(9)="complete the result."
  1.  S XMTEXT="WVMSG("
  1.  D ^XMD
  1.  Q
  1.  ;
  1. CPRS(WVORN,WVDFN,WVORDER,WVPROV,WVMSG,WVIEN) ; Generate a CPRS alert
  1.  ;   WVORN - FILE 100.9 IEN
  1.  ;   WVDFN - FILE 2 IEN
  1.  ; WVORDER - FILE 100 IEN (not currently used)
  1.  ;  WVPROV - FILE 200 IEN
  1.  ;   WVMSG - Free text message
  1.  ;   WVIEN - IEN for a lab or radiology report (not currently used)
  1.  ;
  1.  Q:'$$PATCH^XPDUTL("OR*3.0*210")  ;no pap & mam alerts 
  1.  Q:'WVDFN
  1.  Q:'WVORN
  1.  I WVPROV]"" S WVARRAY(WVPROV)="" ;provider's IEN
  1.  S WVCMGR=$P($G(^WV(790,WVDFN,0)),U,10)
  1.  I WVCMGR]"" S WVARRAY(WVCMGR)="" ;women's health case manager's IEN
  1.  D EN^ORB3(WVORN,WVDFN,WVORDER,.WVARRAY,WVMSG,WVIEN)
  1.  K WVARRAY,WVCMGR
  1.  Q