| [613] | 1 | LEXXFI7 ; ISL/KER - File Info - Prompts and Header ; 02/22/2007
|
|---|
| 2 | ;;2.0;LEXICON UTILITY;**32,49**;Sep 23, 1996;Build 3
|
|---|
| 3 | Q
|
|---|
| 4 | ;
|
|---|
| 5 | ; Global Variables
|
|---|
| 6 | ; ^%ZOSF("UCI") DBIA 10096
|
|---|
| 7 | ; ^%ZOSF("PROD") DBIA 10096
|
|---|
| 8 | ;
|
|---|
| 9 | ; External References
|
|---|
| 10 | ; DBIA 10026 ^DIR
|
|---|
| 11 | ; DBIA 10103 $$FMTE^XLFDT
|
|---|
| 12 | ; DBIA 10103 $$NOW^XLFDT
|
|---|
| 13 | ; DBIA 2056 $$GET1^DIQ (file #200)
|
|---|
| 14 | ; DBIA 10096 ^%ZOSF("UCI")
|
|---|
| 15 | ; DBIA 10096 ^%ZOSF("PROD")
|
|---|
| 16 | ;
|
|---|
| 17 | MT(X) ; Method - One or All Files
|
|---|
| 18 | N DIR,DIROUT,DIRUT,DTOUT,DUOUT,Y
|
|---|
| 19 | S DIR(0)="SAO^O:Checksum for ONE file;A:Checksum for ALL files (LEX/ICD/CPT)"
|
|---|
| 20 | S DIR("A",1)=" Compute Checksum for:",DIR("A",2)=" "
|
|---|
| 21 | S DIR("A",3)=" One Lexicon, ICD or CPT file"
|
|---|
| 22 | S DIR("A",4)=" All Lexicon, ICD or CPT files (757*/80*/81*)"
|
|---|
| 23 | S DIR("A",5)=" ",DIR("A")=" Select One or All: (O/A) "
|
|---|
| 24 | S DIR("B")="O",(DIR("?"),DIR("??"))="^D MTH^LEXXFI7"
|
|---|
| 25 | W ! D ^DIR S X=$S(Y="O":"ONE",Y="A":"ALL",1:"")
|
|---|
| 26 | Q X
|
|---|
| 27 | MTH ; Method Help
|
|---|
| 28 | W !," Do you wish to compute the checksum for a single Lexicon, ICD"
|
|---|
| 29 | W !," or CPT file or all Lexicon, ICD and CPT files (757*/80*/81*)"
|
|---|
| 30 | W:$G(X)["??" !," Answer either 'O'ne or 'A'll or '^' to exit"
|
|---|
| 31 | Q
|
|---|
| 32 | ;
|
|---|
| 33 | CC(X) ; Checksum AND Count
|
|---|
| 34 | N DIR,DIROUT,DIRUT,DTOUT,DUOUT,Y
|
|---|
| 35 | S DIR(0)="YAO",DIR("A")=" Include a Record Count with the Checksum? (Y/N) "
|
|---|
| 36 | S DIR("B")="N",(DIR("?"),DIR("??"))="^D CCH^LEXXFI7"
|
|---|
| 37 | W ! D ^DIR S X=$S(+Y>0:1,1:0)
|
|---|
| 38 | Q X
|
|---|
| 39 | CCH ; Checksum AND Count Help
|
|---|
| 40 | W !," Answer 'Yes' to include a count of the total the number of records"
|
|---|
| 41 | W !," in the file/sub-file along with the checksum"
|
|---|
| 42 | Q
|
|---|
| 43 | ;
|
|---|
| 44 | FI(X) ; Select Lexicon/ICD File
|
|---|
| 45 | N DIR,DIROUT,DIRUT,DTOUT,DUOUT,Y
|
|---|
| 46 | S DIR(0)="FAO^1:45"
|
|---|
| 47 | S DIR("A")=" Select File: "
|
|---|
| 48 | S (DIR("?"),DIR("??"))="^D FIH^LEXXFI7" D ^DIR S X=$$FOT(Y)
|
|---|
| 49 | Q X
|
|---|
| 50 | FIH ; File Help
|
|---|
| 51 | W !," Select either a Lexicon, ICD or CPT file:"
|
|---|
| 52 | W !!," Lexicon ICD CPT"
|
|---|
| 53 | W !," ---------------------------------------- ---- ----"
|
|---|
| 54 | W !," 757 757.03 757.12 757.31 80 81"
|
|---|
| 55 | W !," 757.001 757.03 757.13 757.4 80.1 81.1"
|
|---|
| 56 | W !," 757.01 757.05 757.14 757.41 80.3 81.2"
|
|---|
| 57 | W !," 757.011 757.06 757.2 81.3"
|
|---|
| 58 | W !," 757.014 757.1 757.21"
|
|---|
| 59 | W !," 757.02 757.11 757.3 "
|
|---|
| 60 | Q
|
|---|
| 61 | FOT(X) ; File Output Transform
|
|---|
| 62 | N LEX,LEXX
|
|---|
| 63 | S LEXX=$G(X) Q:'$L(X) "^" D ARY(LEXX,.LEX)
|
|---|
| 64 | S:+($G(LEX(0)))=1 LEXX=$$ONE(X,.LEX)
|
|---|
| 65 | S:+($G(LEX(0)))>1 LEXX=$$MULT(X,.LEX)
|
|---|
| 66 | S X=$S(+LEXX>0:+LEXX,1:"^")
|
|---|
| 67 | Q X
|
|---|
| 68 | ONE(X,LEX) ; One Entry
|
|---|
| 69 | S X=+($G(LEX(1)))
|
|---|
| 70 | I $L($P($G(LEX(1)),"^",2)),+X>0 D
|
|---|
| 71 | . W " ",$P($G(LEX(1)),"^",2)," (#",+X,")"
|
|---|
| 72 | Q:+X'>0 "^" Q X
|
|---|
| 73 | MULT(X,LEX) ; Multiple Entries
|
|---|
| 74 | N LEXE,LEXEX,LEXFI,LEXI,LEXM,LEXMAX,LEXNAM,LEXS
|
|---|
| 75 | S LEXMAX=$G(LEX(0)) Q:+LEXMAX'>1 W ! W !," ",LEXMAX," matches found"
|
|---|
| 76 | S LEXS=0,LEXEX=0 F LEXI=1:1:LEXMAX Q:((LEXS>0)&(LEXS<LEXI+1)) Q:LEXEX D Q:LEXEX
|
|---|
| 77 | . S LEXE=$G(LEX(LEXI)),LEXNAM=$P(LEXE,"^",2),LEXFI=+LEXE Q:'$L(LEXNAM) Q:+LEXFI'>0 S LEXM=LEXI
|
|---|
| 78 | . W:LEXI#5=1 ! W !," ",$J(LEXI,4),". ",LEXNAM," (#",+LEXFI,")"
|
|---|
| 79 | . W:LEXI#5=0 ! S:LEXI#5=0 LEXS=$$SEL(LEXM,.LEX) S:LEXS["^" LEXEX=1
|
|---|
| 80 | I LEXI#5'=0,+LEXS=0 W ! S LEXS=$$SEL(LEXM,.LEX) S:LEXS["^" LEXEX=1
|
|---|
| 81 | S X="^" S:'LEXEX&(+LEXS>0) X=+LEXS S:+X'>0 X="^"
|
|---|
| 82 | Q X
|
|---|
| 83 | SEL(X,LEX) ; Select Multiple
|
|---|
| 84 | N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXM,Y S LEXM=+($G(X)) Q:LEXM=0 -1
|
|---|
| 85 | S:+($O(LEX(+($G(LEXI)))))>0 DIR("A")=" Select 1-"_LEXM_" or '^' to exit: "
|
|---|
| 86 | S:+($O(LEX(+($G(LEXI)))))'>0 DIR("A")=" Select 1-"_LEXM_": "
|
|---|
| 87 | S (DIR("?"),DIR("??"))="Answer must be from 1 to "_LEXM_", or <Return> to continue "
|
|---|
| 88 | S DIR(0)="NAO^1:"_LEXM_":0" D ^DIR S X="" S:$D(DTOUT)!(X[U) X=U
|
|---|
| 89 | I $L($P($G(LEX(+Y)),"^",2)),+($G(LEX(+Y)))>0 D
|
|---|
| 90 | . W " ",$P($G(LEX(+Y)),"^",2)," (#",+($G(LEX(+Y))),")"
|
|---|
| 91 | . S X=+($G(LEX(+Y)))
|
|---|
| 92 | Q X
|
|---|
| 93 | ARY(X,LEX) ; Build Array of Files
|
|---|
| 94 | N LEXF,LEXNM,LEXO,LEXX,Y
|
|---|
| 95 | S LEXX=$TR($G(X),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") N X,Y
|
|---|
| 96 | Q:'$L(LEXX) "" I +LEXX=LEXX D Q
|
|---|
| 97 | . N LEXO,LEXN,LEXC S LEXO=LEXX-.00000001
|
|---|
| 98 | . F S LEXO=$O(@("^DIC("_LEXO_")")) Q:+LEXO=0!($E(LEXO,1,$L(LEXX))'=LEXX) D
|
|---|
| 99 | . . N LEXNM S LEXNM=$$FN^LEXXFI8(LEXO) Q:'$L(LEXNM) S LEX(0)=($O(LEX(" "),-1)+1),LEX(+LEX(0))=+LEXO_"^"_LEXNM
|
|---|
| 100 | S LEXO=$E(LEXX,1,($L(LEXX)-1))_$C($A($E(LEXX,$L(LEXX)))-1)_"~"
|
|---|
| 101 | F S LEXO=$O(@("^DIC(""B"","_LEXO_")")) Q:LEXO="" Q:$E(LEXO,1,$L(LEXX))'[LEXX D
|
|---|
| 102 | . S LEXF=0 F S LEXF=$O(@("^DIC(""B"","_LEXO_","_LEXF_")")) Q:+LEXF'>0 D
|
|---|
| 103 | . . Q:+($$LEX^LEXXFI8(LEXF))'>0&(+($$IC^LEXXFI8(LEXF))'>0) N LEXNM S LEXNM=$$FN^LEXXFI8(LEXF)
|
|---|
| 104 | . . Q:'$L(LEXNM) S LEX(0)=($O(LEX(" "),-1)+1),LEX(+LEX(0))=+LEXF_"^"_LEXNM
|
|---|
| 105 | Q
|
|---|
| 106 | ;
|
|---|
| 107 | ; Miscellaneous
|
|---|
| 108 | U(X) ; UCI where Lexicon is installed
|
|---|
| 109 | N LEXU,LEXP,LEXT,Y X ^%ZOSF("UCI") S LEXU=Y,LEXP="" S:LEXU=^%ZOSF("PROD")!($P(LEXU,",",1)=^%ZOSF("PROD")) LEXP=" (Production)"
|
|---|
| 110 | S:LEXU'=^%ZOSF("PROD")&($P(LEXU,",",1)'=^%ZOSF("PROD")) LEXP=" (Test)" S X="",$P(X,"^",1)=LEXU,$P(X,"^",2)=LEXP
|
|---|
| 111 | Q X
|
|---|
| 112 | A(X) ; As of date/time
|
|---|
| 113 | N LEXX S LEXX=$$NOW^XLFDT,LEXX=$$FMTE^XLFDT(LEXX,"1")
|
|---|
| 114 | S:LEXX["@" LEXX=$P(LEXX,"@",1)_" "_$P(LEXX,"@",2,299)
|
|---|
| 115 | S X=LEXX
|
|---|
| 116 | Q X
|
|---|
| 117 | P(X) ; Person
|
|---|
| 118 | N LEXDUZ,LEXPH,LEXNM
|
|---|
| 119 | S LEXDUZ=+($G(DUZ)),LEXNM=$$GET1^DIQ(200,+($G(LEXDUZ)),.01) Q:'$L(LEXNM) "UNKNOWN^"
|
|---|
| 120 | S LEXDUZ=+($G(DUZ)) S LEXPH=$$GET1^DIQ(200,+($G(LEXDUZ)),.132)
|
|---|
| 121 | S:LEXPH="" LEXPH=$$GET1^DIQ(200,+($G(LEXDUZ)),.133)
|
|---|
| 122 | S:LEXPH="" LEXPH=$$GET1^DIQ(200,+($G(LEXDUZ)),.134)
|
|---|
| 123 | S:LEXPH="" LEXPH=$$GET1^DIQ(200,+($G(LEXDUZ)),.135)
|
|---|
| 124 | S LEXDUZ=$$PM(LEXNM)
|
|---|
| 125 | S X=LEXDUZ_"^"_LEXPH
|
|---|
| 126 | Q X
|
|---|
| 127 | PM(X) ; Person, Mixed Case
|
|---|
| 128 | N LEXF,LEXL,LEXP S LEXP=$G(X),LEXL=$$MX($P(LEXP,",",1)),LEXF=$P(LEXP,",",2)
|
|---|
| 129 | S LEXL(1)=$$MX($P(LEXL,"-",1)),LEXL(2)=$$MX($P(LEXL(1)," ",2,2)),LEXL(1)=$$MX($P(LEXL(1)," ",1))
|
|---|
| 130 | S:$L(LEXL(1))&($L(LEXL(2))) LEXL(1)=LEXL(1)_" "_LEXL(2)
|
|---|
| 131 | S LEXL(3)=$$MX($P(LEXL,"-",2)),LEXL(4)=$$MX($P(LEXL(3)," ",2,2)),LEXL(3)=$$MX($P(LEXL(3)," ",1))
|
|---|
| 132 | S:$L(LEXL(3))&($L(LEXL(4))) LEXL(3)=LEXL(3)_" "_LEXL(4)
|
|---|
| 133 | S LEXL=LEXL(1) S:$L(LEXL(1))&($L(LEXL(3))) LEXL=LEXL(1)_"-"_LEXL(3)
|
|---|
| 134 | S LEXF=$$MX($P(LEXP,",",1)),LEXF=$P(LEXP,",",2)
|
|---|
| 135 | S LEXF(1)=$$MX($P(LEXF,"-",1)),LEXF(2)=$$MX($P(LEXF(1)," ",2,2)),LEXF(1)=$$MX($P(LEXF(1)," ",1))
|
|---|
| 136 | S:$L(LEXF(1))&($L(LEXF(2))) LEXF(1)=LEXF(1)_" "_LEXF(2)
|
|---|
| 137 | S LEXF(3)=$$MX($P(LEXF,"-",2)),LEXF(4)=$$MX($P(LEXF(3)," ",2,2)),LEXF(3)=$$MX($P(LEXF(3)," ",1))
|
|---|
| 138 | S:$L(LEXF(3))&($L(LEXF(4))) LEXF(3)=LEXF(3)_" "_LEXF(4)
|
|---|
| 139 | S LEXF=LEXF(1) S:$L(LEXF(1))&($L(LEXF(3))) LEXF=LEXF(1)_"-"_LEXF(3)
|
|---|
| 140 | S LEXP=LEXL_", "_LEXF,X=LEXP
|
|---|
| 141 | Q X
|
|---|
| 142 | MX(X) ; Mix Case
|
|---|
| 143 | Q $TR($E(X,1),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$TR($E(X,2,$L(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
|
|---|
