source: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMCWH.m@ 636

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