source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXPL.m@ 1806

Last change on this file since 1806 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.8 KB
Line 
1LEXPL ; ISL Problem List Survey ; 05/14/2003
2 ;;2.0;LEXICON UTILITY;**25**;Sep 23, 1996;Build 1
3 ;
4 ; Entry Points
5 ;
6 ; EN^LEXPL Task Survey and Sends Mailman Message to ISC-IRMFO
7 ; SV^LEXPL Performs Survey (no task) and displays results
8 ;
9EN ; Tasked Survey
10 S ZTRTN="SV^LEXPL",ZTDESC="Problem List Survey",ZTIO="",ZTDTH=$H D ^%ZTLOAD D HOME^%ZIS K %X,%Y,Y,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN Q
11SV ; Operational Survey
12 K ^TMP("LEXS") D UD,PLUR,SG,SEND K:'$D(ZTQUEUED) ^TMP("LEXS") S:$D(ZTQUEUED) ZTREQ="@" Q
13UD ; UCI/Date
14 N %,%H,%I,X,Y X ^%ZOSF("UCI") D SET("Problem List Survey"),BL S X=" UCI: "_Y
15 D:Y=$G(^%ZOSF("PROD")) SET((X_" (Production)")) D:Y'=$G(^%ZOSF("PROD")) SET((X_" (Test)"))
16 S X=$$DT Q:X="" D SET((" ON: "_$P(X,"^",1)_" at "_$P(X,"^",2))),BL Q
17PLUR ; Survey
18 N LEXD,LEXCE,LEXCI,LEXICD,LEXIIC,LEXLC,LEXPE,LEXLI,LEXLU,LEXPU,LEXUC,LEXUI,LEXCU,LEXUU,X
19 S:$D(ZTQUEUED) LEXCE=$$EN2^LEXPLEM,LEXCI=$$EN2^LEXPLIA,LEXCU=$$EN2^LEXPLUP
20 S (LEXD,LEXUU,LEXUI,LEXUC,LEXLU,LEXLI,LEXLC,LEXPU)=0
21 S LEXPU=$O(^ICD9("AB","799.9 ",LEXPU)) Q:LEXPU=0
22 F S LEXD=$O(^AUPNPROB(LEXD)) Q:+LEXD=0 D
23 . S LEXICD=+($G(^AUPNPROB(LEXD,0))),LEXPE=+($G(^AUPNPROB(LEXD,1)))
24 . S LEXIIC=+($P($G(^ICD9(LEXICD,0)),"^",9))
25 . S:LEXPE>1&(LEXICD=LEXPU) LEXLU=LEXLU+1
26 . S:LEXPE=1&(LEXICD=LEXPU) LEXUU=LEXUU+1
27 . S:LEXPE=1&(LEXICD'=LEXPU)&(LEXIIC=0) LEXUC=LEXUC+1
28 . S:LEXPE>1&(LEXICD'=LEXPU)&(LEXIIC=0) LEXLC=LEXLC+1
29 . S:LEXPE=1&(LEXICD'=LEXPU)&(LEXIIC=1) LEXUI=LEXUI+1
30 . S:LEXPE>1&(LEXICD'=LEXPU)&(LEXIIC=1) LEXLI=LEXLI+1
31 ;
32 ; Titles
33 ;
34 D SET(" "),SET2(""),SET2("Inactive"),SET2("Active")
35 D SET(" "),SET2("Uncoded"),SET2("ICD Code"),SET2("ICD Code"),SET2("Total"),BL
36 ;
37 ; Unresolved
38 ;
39 D SET(" Unresolved Narratives")
40 D SET2(LEXUU) D SET2(LEXUI)
41 D SET2(LEXUC) D SET2((LEXUU+LEXUC+LEXUI))
42 ;
43 ; Lexicon
44 ;
45 D SET(" Lexicon Terms")
46 D SET2(LEXLU) D SET2(LEXLI)
47 D SET2(LEXLC) D SET2((LEXLU+LEXLC+LEXLI))
48 ;
49 ; Total
50 ;
51 D SET(" ---------------------------------------------------------------------")
52 D SET(" Total Problems")
53 D SET2(LEXUU+LEXLU),SET2(LEXUI+LEXLI)
54 D SET2(LEXUC+LEXLC),SET2((LEXUU+LEXUC+LEXUI+LEXLU+LEXLC+LEXLI))
55 ;
56 I +($G(LEXCE))>0!(+($G(LEXCI))>0)!(+($G(LEXCU))>0) D
57 . D BL N LEXD S LEXCE=+($G(LEXCE)),LEXCI=+($G(LEXCI)),LEXCU=+($G(LEXCU))
58 . S LEXD=$L(LEXCE) S:$L(LEXCI)>LEXD LEXD=$L(LEXCI) S:$L(LEXCU)>LEXD LEXD=$L(LEXCU) S LEXD=LEXD+1
59 . I LEXCE>0 D SET(($J(LEXCE,LEXD)_" Exact match unresolved narratives resolved to to the Lexicon"))
60 . I LEXCI>0 D SET(($J(LEXCI,LEXD)_" Inactive ICD codes/6 digit codes re-coded to an active ICD Code"))
61 . I LEXCU>0 D SET(($J(LEXCU,LEXD)_" Uncoded Lexicon terms re-coded to an ICD code other than 799.9"))
62 . D BL
63 K LEXD,LEXCE,LEXCI,LEXICD,LEXIIC,LEXLC,LEXPE,LEXLI,LEXLU,LEXPU,LEXUC,LEXUI,LEXCU,LEXUU,X
64 Q
65SG ; Show survey
66 Q:$D(ZTQUEUED) N LEXD S LEXD=0
67 F S LEXD=$O(^TMP("LEXS",LEXD)) Q:+LEXD=0 W !,^TMP("LEXS",LEXD)
68 W !! Q
69SEND ; Mailman
70 N DIFROM,LEXADR Q:'$D(ZTQUEUED) S LEXADR=$$ADR^LEXU Q:'$L(LEXADR)
71 K XMZ S XMSUB="Lexicon/Problem List Survey"
72 S XMY(("G.LEXICON@"_LEXADR))=""
73 S XMTEXT="^TMP(""LEXS"",",XMDUZ=.5
74 D ^XMD K ^TMP("LEXS"),XCNP,XMDUZ,XMY,XMZ,XMSUB,XMTEXT,XMDUZ
75 S:$D(ZTQUEUED) ZTREQ="@" Q
76BL ; Blank
77 D SET("") Q
78SET(X) ; Column 1
79 S X=$G(X),^TMP("LEXS",0)=+($G(^TMP("LEXS",0)))+1,^TMP("LEXS",+($G(^TMP("LEXS",0))))=X Q
80SET2(X) ; Column X
81 S X=$G(X),X=$$L($G(^TMP("LEXS",+($G(^TMP("LEXS",0))))))_" "_$J(X,8),^TMP("LEXS",+($G(^TMP("LEXS",0))))=X Q
82L(X) ; Lengthen text
83 F Q:$L(X)=25!($L(X)>25) S X=X_" "
84 Q X
85T(X) ; Trim text
86 S X=$G(X) F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
87 F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
88 Q X
89DT(X) ; Date and time
90 N %,%H,%I,X,Y D NOW^%DTC Q:+($G(X))=0 "" S X=$$FMTE^XLFDT(%,"1P") Q:$L(X," ")'=5 "" Q:$P(X," ",4)'[":" "" Q:$P(X," ",5)'["m" ""
91 S X=$P(X," ",1,3)_"^"_$P($P(X," ",4),":",1,2)_" "_$P(X," ",5)
92 Q X
Note: See TracBrowser for help on using the repository browser.