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

PXRMCWH.m

Go to the documentation of this file. 
  1. PXRMCWH ; SLC/AGP - Computed findings for WH project. ;06/09/2006
  1.  ;;2.0;CLINICAL REMINDERS;**1,4**;Feb 4, 2005;Build 21
  1.  ;
  1. MAM(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding for
  1.  ;mammogram screening and review
  1.  ;
  1.  N CNT,CNT1,RESULT,WHDATE
  1.  S NGET=$S(NGET<0:-NGET,1:NGET)
  1.  S (CNT1,CNT,NFOUND)=0,DATE=$$NOW^PXRMDATE,TEST(1)=0
  1.  I $G(BDT)'="",$G(EDT)'="" S WHDATE=BDT_U_EDT
  1.  D LATEST^WVRPCPR(.RESULT,DFN,"M",$G(WHDATE),$G(NGET),"*")
  1.  I $D(RESULT)>0 D PROCESS(.RESULT,.CNT1,.TEST,.DATA,.TEXT,NGET,BDT,EDT,NFOUND)
  1.  I $G(CNT1)>0 S NFOUND=CNT1
  1.  Q
  1.  ;
  1. MAMA(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding for
  1.  ;mammogram abnormal result
  1.  ;
  1.  N CNT,CNT1,RESULT,WHDATE
  1.  S NGET=$S(NGET<0:-NGET,1:NGET)
  1.  S (CNT1,CNT,NFOUND)=0,DATE=$$NOW^PXRMDATE,TEST(1)=0
  1.  I $G(BDT)'="",$G(EDT)'="" S WHDATE=BDT_U_EDT
  1.  D LATEST^WVRPCPR(.RESULT,DFN,"M",$G(WHDATE),$G(NGET),"A")
  1.  I $D(RESULT)>0 D PROCESS(.RESULT,.CNT1,.TEST,.DATA,.TEXT,NGET,BDT,EDT,NFOUND)
  1.  I $G(CNT1)>0 S NFOUND=CNT1
  1.  Q
  1.  ;
  1. PAP(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed
  1.  ;finding for pap smear screening and review
  1.  ;
  1.  N CNT,CNT1,RESULT,WHDATE
  1.  S NGET=$S(NGET<0:-NGET,1:NGET)
  1.  S (CNT1,CNT,NFOUND)=0,DATE=$$NOW^PXRMDATE,TEST(1)=0
  1.  I $G(BDT)'="",$G(EDT)'="" S WHDATE=BDT_U_EDT
  1.  D LATEST^WVRPCPR(.RESULT,DFN,"P",$G(WHDATE),$G(NGET),"*")
  1.  I $D(RESULT)>0 D PROCESS(.RESULT,.CNT1,.TEST,.DATA,.TEXT,NGET,BDT,EDT,NFOUND)
  1.  I $G(CNT1)>0 S NFOUND=CNT1
  1.  Q
  1.  ;
  1.  ;
  1. PAPA(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding for
  1.  ;pap smear abnormal result
  1.  ;
  1.  N CNT,CNT1,RESULT,WHDATE
  1.  S NGET=$S(NGET<0:-NGET,1:NGET)
  1.  S (CNT1,CNT,NFOUND)=0,DATE=$$NOW^PXRMDATE,TEST(1)=0
  1.  I $G(BDT)'="",$G(EDT)'="" S WHDATE=BDT_U_EDT
  1.  D LATEST^WVRPCPR(.RESULT,DFN,"P",$G(WHDATE),$G(NGET),"A")
  1.  I $D(RESULT)>0 D PROCESS(.RESULT,.CNT1,.TEST,.DATA,.TEXT,NGET,BDT,EDT,NFOUND)
  1.  I $G(CNT1)>0 S NFOUND=CNT1
  1.  Q
  1.  ;
  1.  ;
  1. PROCESS(RESULT,CNT1,TEST,DATA,TEXT,NGET,BDT,EDT,NFOUND) ;
  1.  ;Pieces out data in Result for Reminder evaluation
  1.  N DATE1
  1.  I $P($G(RESULT(0)),U)<0 Q
  1.  F  S CNT=$O(RESULT(CNT)) Q:CNT=""!(CNT1>$G(NGET))  I CNT'=0 D
  1.  . S DATE1=$P($G(RESULT(CNT)),U,3)
  1.  . I $G(BDT)'="",$G(EDT)'="",EDT<BDT Q
  1.  . S CNT1=CNT1+1
  1.  . S TEST(CNT1)=0
  1.  . S DATA(CNT1,"LINK")=$P($G(RESULT(CNT)),U,7)
  1.  . S DATA(CNT1,"STATUS")=$P($G(RESULT(CNT)),U,8)
  1.  . S DATA(CNT1,"VALUE")=$P($G(RESULT(CNT)),U,5)
  1.  . S DATA(CNT1,"WVIEN")=$P($G(RESULT(CNT)),U)
  1.  . S TEST(CNT1)=1,DATE(CNT1)=$G(DATE1)
  1.  . S TEXT(CNT1)=$P($G(RESULT(CNT)),U,4)_" "_$P($G(RESULT(CNT)),U,6)
  1.  . ;S VALUE(CNT1)=$P($G(RESULT(CNT)),U,5)
  1.  Q
  1.  ;
  1. PAPSCR(DFN,NGET,BDT,EDT,NFOUND,TEST,DATE,DATA,TEXT) ;Computed finding for
  1.  ;pap smear screening and f/u
  1.  ;
  1.  N CNT,CNT1,CNT2,DATE1,DS,EDTT,IND,JND,MOR,MORIEN,NODE,OD
  1.  N PXRMWVT,PXRMWVM
  1.  N SDIR,SNOWCNT,TDATA,TDATE,TOP,TTEST,TTEXT,SNOWTOP,NODE,WVPAP
  1.  N DAS,DAS0,DAS1,DAS2,DAS3,DAS4,DAS5
  1.  S NFOUND=0
  1.  S WVPAP=$O(^WV(790.2,"B","PAP SMEAR",""))
  1.  S SNOWCNT=0,CNT=0
  1.  ;Get SNOMED Morphology codes from file 790.2
  1.  F  S SNOWCNT=$O(^WV(790.2,WVPAP,1,SNOWCNT)) Q:+SNOWCNT'>0  D
  1.  .S PXRMWVM($P($G(^WV(790.2,WVPAP,1,SNOWCNT,0)),U))=$P($G(^WV(790.2,WVPAP,1,SNOWCNT,0)),U,2)
  1.  ;
  1.  ;Get SNOMED Topography codes from file 790.2
  1.  S SNOWCNT=0 F  S SNOWCNT=$O(^WV(790.2,WVPAP,2,SNOWCNT)) Q:+SNOWCNT'>0  D
  1.  .S PXRMWVT($P($G(^WV(790.2,WVPAP,2,SNOWCNT,0)),U))=""
  1.  ;
  1.  ;If no topography codes quit
  1.  I $D(PXRMWVT)'>0 S DATA(1,"VALUE")="NO TOPOGRAPHY CODES FOUND",TEST(1)=0,TEXT(1)="     " Q
  1.  ;
  1.  ;Handle search direction and date ranges
  1.  S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
  1.  S SDIR=$S(NGET<0:+1,1:-1)
  1.  S DS=$S(SDIR=+1:BDT-.000001,1:EDTT)
  1.  S NGET=$S(NGET<0:-NGET,1:NGET)
  1.  ;
  1.  ;Match Topography codes in PXRMINDX for Lab
  1.  N DTARRAY,NODE1,TCNT,ODATE1
  1.  S TOP=0,CNT1=0,TCNT=0,ODATE1=0 F  S TOP=$O(PXRMWVT(TOP)) Q:+TOP'>0!(CNT1=NGET)  D
  1.  .S SNOWTOP="A;O;"_TOP,DATE1=DS
  1.  .F  S DATE1=+$O(^PXRMINDX(63,"PI",DFN,SNOWTOP,DATE1),SDIR) Q:$S(DATE1'>0:1,DATE1<BDT:1,DATE1>EDTT:1,1:0)  D
  1.  ..S DAS=$O(^PXRMINDX(63,"PI",DFN,SNOWTOP,DATE1,""))
  1.  ..;
  1.  ..;set date to dtarray to hanle multiple snomed done on the same date
  1.  ..S DTARRAY(DATE1)=$S($D(DTARRAY(DATE1)):DTARRAY(DATE1)+1,1:1)
  1.  ..S DTARRAY(DATE1,DTARRAY(DATE1))=TOP_U_DAS
  1.  ;
  1.  ;loop through date array
  1.  N DAS
  1.  S DATE1=DS F  S DATE1=$O(DTARRAY(DATE1),SDIR) Q:$S(DATE1'>0:1,CNT1=NGET:1,1:0)  D
  1.  .S TCNT=0,CNT1=CNT1+1 F  S TCNT=$O(DTARRAY(DATE1,TCNT)) Q:TCNT'>0  D
  1.  ..S NODE1=$G(DTARRAY(DATE1,TCNT))
  1.  ..S TDATE(CNT1)=DATE1,NODE=$G(^LAB(61,$P(NODE1,U),0)),DAS=$P(NODE1,U,2)
  1.  ..S TTEST(CNT1)=0
  1.  ..;
  1.  ..;set TDATA to value
  1.  ..S TDATA(CNT1,"SNOMED",TCNT,"VALUE")="T-"_$P(NODE,U,2)_" "_$P(NODE,U)
  1.  ..I '$D(TTEXT(CNT1)) S TTEXT(CNT1)=TDATA(CNT1,"SNOMED",TCNT,"VALUE")_" - "
  1.  ..E  I $L(TTEXT(CNT1))+$L(TDATA(CNT1,"SNOMED",TCNT,"VALUE"))<255 D
  1.  ...I $E(TTEXT(CNT1),$L(TTEXT(CNT1)))="\" S TTEXT(CNT1)=TTEXT(CNT1)_TDATA(CNT1,"SNOMED",TCNT,"VALUE")_" - "
  1.  ..S TDATA(CNT1,"SNOMED",TCNT,"TOPH")="T-"_$P(NODE,U,2)
  1.  ..;
  1.  ..;Dig down into Lab file to find a match for morphology codes
  1.  ..S SNOWCNT=0,DAS0=$P($G(DAS),";"),DAS1=$P($G(DAS),";",3)
  1.  ..S DAS2=$P(DAS,";",4),DAS3=$P(DAS,";",5)
  1.  ..S CNT2=0,NODE=""
  1.  ..;
  1.  ..;get Morphology results
  1.  ..N MCNT S MCNT=0
  1.  ..S TDATA(CNT1,"UNSATISFACTORY")="F"
  1.  ..F  S SNOWCNT=$O(^LR(DAS0,"CY",DAS1,DAS2,DAS3,2,SNOWCNT)) Q:+SNOWCNT'>0  D
  1.  ...S MORIEN=^LR(DAS0,"CY",DAS1,DAS2,DAS3,2,SNOWCNT,0)
  1.  ...I $D(PXRMWVM(MORIEN))>0 D
  1.  ....S TTEST(CNT1)=1,MCNT=MCNT+1
  1.  ....;
  1.  ....;handle multiple SNOMED entries for the same date
  1.  ....S NODE=^LAB(61.1,MORIEN,0)
  1.  ....N STR
  1.  ....I '$D(TTEXT(CNT1))  S TTEXT(CNT1)="M-"_$P(NODE,U,2)_" "_$P(NODE,U)
  1.  ....E  D
  1.  .....S STR="M-"_$P(NODE,U,2)_" "_$P(NODE,U)
  1.  .....I $L(TTEXT(CNT1))+STR'<255 Q
  1.  .....S TTEXT(CNT1)=TTEXT(CNT1)_STR_";"
  1.  ....;
  1.  ....S TDATA(CNT1,"SNOMED",TCNT,MCNT,"MORP")="M-"_$P(NODE,U,2)
  1.  ....S TDATA(CNT1,"SNOMED",TCNT,MCNT,"RESULT STATUS")=$S(PXRMWVM(MORIEN)="0":"NEM",PXRMWVM(MORIEN)="1":"Abnormal",PXRMWVM(MORIEN)="2":"Unsatisfactory",1:"Unknown")
  1.  ....I TDATA(CNT1,"SNOMED",TCNT,MCNT,"RESULT STATUS")["Un" S TDATA(CNT1,"UNSATISFACTORY")="T"
  1.  ....I $L(TTEXT(CNT1))+$L("\\")<255 S TTEXT(CNT1)=TTEXT(CNT1)_"\\"
  1.  S NFOUND=CNT1
  1.  N DATE1,CNT,TCNT
  1.  F IND=1:1:NFOUND S OD(TDATE(IND),IND)=""
  1.  S CNT1=0,IND=""
  1.  F  S IND=$O(OD(IND),SDIR) Q:IND=""  D
  1.  . S JND=0
  1.  . F  S JND=$O(OD(IND,JND)) Q:JND=""  D
  1.  .. S CNT1=CNT1+1
  1.  .. S DATE(CNT1)=IND
  1.  .. S TEST(CNT1)=TTEST(JND)
  1.  .. M DATA(CNT1)=TDATA(JND)
  1.  .. S TEXT(CNT1)=TTEXT(JND)
  1.  Q
  1.  ;