LEXXGI3 ;ISL/KER - Global Import (Load Data in ^LEXM) ;05/23/2017
;;2.0;LEXICON UTILITY;**59,80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEXM( N/A
;
; External References
; $$S^%ZTLOAD ICR 10063
; ^DIM ICR 10016
; $$ROOT^ICDEX ICR 5747
; $$DT^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
;
; Local Variables NEWed or KILLed Elsewhere
;
; LEXFL Array of Files
; LEXOK LEXM exist
; LEXSCHG Changes
; ZTQUEUED Queued Task
; ZTSK Task Number
;
FILES ; Load Data for all files
Q:'$L($G(LEXB)) N LEXHDR,LEXBLD,LEXDAT,LEXFI,LEXFIC,LEXHDRS,LEXLOG,LEXINS,LEXTOTI,LEXTOTN,LEXPER,LEXPRE
S (LEXFI,LEXFIC,LEXHDR,LEXTOTI,LEXTOTN,LEXPER,LEXPRE)=0,LEXBLD=LEXB
S LEXDAT=$P($G(^LEXM(0,"VRRVDT")),"^",1),LEXINS=1
S:+LEXDAT'>0 LEXDAT=$$DT^XLFDT I LEXOK D
. N LEXCRE,LEXL1 S LEXL1="" S LEXCRE=$G(^LEXM(0,"CREATED")) S LEXCRE=$S(+LEXCRE>0:($$MIX^LEXXGI2($$FMTE^XLFDT(LEXCRE))),1:"")
. S:$L($P(LEXCRE,"@",2)) LEXCRE=$P(LEXCRE,"@",1)_" at "_$P(LEXCRE,"@",2) S LEXL1=" Updating files "
. S:$L($G(LEXCRE))&($L($G(LEXL1))) LEXL1=$G(LEXL1)_"using export global created "_$G(LEXCRE)
. D PB^LEXXGI2(LEXL1)
S LEXFI=0 F S LEXFI=$O(^LEXM(LEXFI)) Q:+LEXFI=0 S LEXTOTN=+($G(LEXTOTN))+($O(^LEXM(LEXFI," "),-1))
S LEXFI=0 F S LEXFI=$O(^LEXM(LEXFI)) Q:+LEXFI=0 D FILE
Q
FILE ; Load Data for one file
N LEXCF,LEXCHG,LEXCHGS,LEXCNT,LEXFIL,LEXI,LEXID,LEXIEN,LEXL,LEXLC
N LEXMUMPS,LEXNM,LEXRT,LEXS,LEXTOT,LEXTXT,LEXIGL,LEXIGI,LEXIGF,LEXIGT
N LEXIGD,LEXIGO,LEXBEG,LEXEND,LEXELP,LEXFB
S LEXFB=$G(^LEXM(+LEXFI,0,"BUILD")),LEXIGO=0,LEXBEG=$$HACK^LEXXGI2
S (LEXCNT,LEXLC,LEXI)=0,LEXL=68,LEXFIC=LEXFIC+1 I LEXOK D
. N LEXB,LEXFID,LEXNM,LEXVR,LEXRV,LEXDT,LEXL1,LEXL2 S (LEXL1,LEXL2)="",LEXFID=$P(LEXFI,".",1)
. Q:+LEXFID'>0 Q:$D(LEXHDRS(+LEXFID)) S LEXHDRS(LEXFID)="" S:+LEXFI=81!(+LEXFI=81.3) LEXHDRS(81)="",LEXHDRS(81.3)=""
. S:LEXFID=80 LEXNM="ICD-9-CM" S:LEXFID=81 LEXNM="CPT-4/HCPCS" S:LEXFID=757 LEXNM="Lexicon" S LEXB=$G(^LEXM(LEXFI,0,"BUILD"))
. S LEXVR=$G(^LEXM(LEXFI,0,"VR")),LEXRV=$G(^LEXM(LEXFI,0,"VRRV")),LEXDT=$$MIX^LEXXGI2($$FMTE^XLFDT($P(LEXRV,"^",2))),LEXRV=$P(LEXRV,"^",1)
. S LEXL1="Updating "_LEXNM S:$L(LEXB) LEXL1=LEXL1_" with patch/build "_LEXB S:$L(LEXVR) LEXL2=" To version "_LEXVR
. S:$L(LEXVR)&($L(LEXRV)) LEXL2=LEXL2_" revision "_LEXRV S:$L(LEXVR)&($L(LEXRV))&($L(LEXDT)) LEXL2=LEXL2_" dated "_LEXDT
. S:$L(LEXL1) LEXL1=" "_LEXL1 S:$L(LEXL2) LEXL2=" "_LEXL2 D BL^LEXXGI2 D:$L(LEXL1) TL^LEXXGI2(LEXL1) D:$L(LEXL2) TL^LEXXGI2(LEXL2),BL^LEXXGI2
S LEXTOT=+($G(^LEXM(LEXFI,0))) G:LEXTOT=0 FILEQ
S LEXNM=$G(^LEXM(LEXFI,0,"NM"))
I $L(LEXNM),$$UP^LEXXGI2(LEXNM)'["FILE" S LEXNM=LEXNM_" FILE"
S:$L(LEXNM) LEXNM=$$MIX^LEXXGI2(LEXNM) S LEXCHG=$G(^LEXM(LEXFI,0))
S LEXTXT=" "_LEXNM,LEXTXT=LEXTXT_$J("",(40-$L(LEXTXT)))_LEXFI
D:LEXFIC=1 PB^LEXXGI2(LEXTXT) D:LEXFIC'=1 TL^LEXXGI2(LEXTXT)
S LEXS=+(LEXTOT\LEXL) S:LEXS=0 LEXS=1 W:+($O(^LEXM(LEXFI,0)))>0 !," "
D UPCHG^LEXXGI2 F S LEXI=$O(^LEXM(LEXFI,LEXI)) Q:+LEXI=0 D
. S LEXCNT=LEXCNT+1,LEXMUMPS=$G(^LEXM(LEXFI,LEXI))
. I LEXCNT'<LEXS S LEXLC=LEXLC+1 W:LEXLC'>LEXL "." S LEXCNT=0
. S LEXRT=$P(LEXMUMPS,"^",2),LEXFIL=""
. S:LEXMUMPS["^LEX("!(LEXMUMPS["^LEXT(")!(LEXMUMPS["^LEXC(") LEXFIL=+($P(LEXRT,"(",2)),LEXFL(+($P(LEXRT,"(",2)))=""
. S:LEXMUMPS[$$ROOT^ICDEX(80) LEXFIL=80,LEXFL(80)=""
. S:LEXMUMPS[$$ROOT^ICDEX(80.1) LEXFIL=80.1,LEXFL(80.1)=""
. S:LEXMUMPS["^ICPT(" LEXFIL=81,LEXFL(81)=""
. S:LEXMUMPS["^DIC(81.3" LEXFIL=81.3,LEXFL(81.3)=""
. S:LEXMUMPS["^DIC(81.2" LEXFIL=81.2,LEXFL(81.2)=""
. S:+LEXFIL>0 LEXSCHG(+LEXFIL,0)=""
. I $L(LEXMUMPS) D
. . X LEXMUMPS S LEXIGO=1
. . S LEXTOTI=+($G(LEXTOTI))+1 I +($G(LEXTOTN))>0,+($G(LEXTOTI))>0,$D(ZTQUEUED),+($G(ZTSK))>0 D
. . . N LEXT,LEXTSK S (LEXT,LEXPER)=(+($G(LEXTOTI))/+($G(LEXTOTN)))*100 Q:+LEXPER-(+($G(LEXPRE)))'>2 S LEXPRE=+($G(LEXPER))
. . . S LEXPER=$J(LEXPER,6,2) I +LEXT>0 S LEXPER=LEXPER_"% complete" S LEXTSK=$$S^%ZTLOAD(LEXPER)
I +($G(LEXIGO))>0 D
. S LEXEND=$$HACK^LEXXGI2 S LEXELP=$$ELAP^LEXXGI2(LEXBEG,LEXEND) S:LEXELP="" LEXELP="00:00:00"
FILEQ ; Load Data for one file - QUIT
Q
UTOT ; CSV Totals
N Y,ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSAVE,ZTQUEUED,ZTREQ S ZTRTN="UTOTS^LEXXGI3"
S ZTDESC="Update HIPAA CSV Totals in file 757.03" S:$D(LEXALL) ZTSAVE("LEXALL")=""
S ZTIO="",ZTDTH=$H D ^%ZTLOAD,HOME^%ZIS K LEXALL
Q
UTOTS ; CSV Totals
N LEXA,LEXB,LEXD,LEXE,LEXH,LEXI,LEXS,LEXT,LEXTD,LEXFD
S (LEXI,LEXT,LEXA)=0 F S LEXI=$O(@("^ICD9("_LEXI_")")) Q:+LEXI'>0!(LEXI>499999) D
. N LEXE,LEXH,LEXS S LEXT=LEXT+1
. S LEXE=$O(@("^ICD9("_+LEXI_",66,""B"","" "")"),-1) Q:LEXE'?7N
. S LEXH=$O(@("^ICD9("_+LEXI_",66,""B"","_+LEXE_","" "")"),-1) Q:LEXH'?1N.N
. S LEXS=+($P($G(@("^ICD9("_+LEXI_",66,"_+LEXH_",0)")),"^",2)) S:+LEXS>0 LEXA=LEXA+1
S:LEXT>0 $P(^LEX(757.03,1,0),"^",6)=+LEXT S $P(^LEX(757.03,1,0),"^",5)=+LEXA
S (LEXI,LEXT,LEXA)=0 F S LEXI=$O(@("^ICD0("_LEXI_")")) Q:+LEXI'>0!(LEXI>499999) D
. N LEXE,LEXH,LEXS S LEXT=LEXT+1
. S LEXE=$O(@("^ICD0("_+LEXI_",66,""B"","" "")"),-1) Q:LEXE'?7N
. S LEXH=$O(@("^ICD0("_+LEXI_",66,""B"","_+LEXE_","" "")"),-1) Q:LEXH'?1N.N
. S LEXS=+($P($G(@("^ICD0("_+LEXI_",66,"_+LEXH_",0)")),"^",2)) S:+LEXS>0 LEXA=LEXA+1
S:LEXT>0 $P(^LEX(757.03,2,0),"^",6)=+LEXT S $P(^LEX(757.03,2,0),"^",5)=+LEXA
S LEXI=499999,(LEXA,LEXT)=0 F S LEXI=$O(@("^ICD9("_LEXI_")")) Q:+LEXI'>0 D
. N LEXE,LEXH,LEXS S LEXT=LEXT+1
. S LEXE=$O(@("^ICD9("_+LEXI_",66,""B"","" "")"),-1) Q:LEXE'?7N
. S LEXH=$O(@("^ICD9("_+LEXI_",66,""B"","_+LEXE_","" "")"),-1) Q:LEXH'?1N.N
. S LEXS=+($P($G(@("^ICD9("_+LEXI_",66,"_+LEXH_",0)")),"^",2)) S:+LEXS>0 LEXA=LEXA+1
S:LEXT>0 $P(^LEX(757.03,30,0),"^",6)=+LEXT S $P(^LEX(757.03,30,0),"^",5)=+LEXA
S LEXI=499999,(LEXA,LEXT)=0 F S LEXI=$O(@("^ICD0("_LEXI_")")) Q:+LEXI'>0 D
. N LEXE,LEXH,LEXS S LEXT=LEXT+1
. S LEXE=$O(@("^ICD0("_+LEXI_",66,""B"","" "")"),-1) Q:LEXE'?7N
. S LEXH=$O(@("^ICD0("_+LEXI_",66,""B"","_+LEXE_","" "")"),-1) Q:LEXH'?1N.N
. S LEXS=+($P($G(@("^ICD0("_+LEXI_",66,"_+LEXH_",0)")),"^",2)) S:+LEXS>0 LEXA=LEXA+1
S:LEXT>0 $P(^LEX(757.03,31,0),"^",6)=+LEXT S $P(^LEX(757.03,31,0),"^",5)=+LEXA
S (LEXI,LEXT,LEXH,LEXA,LEXB)=0 F S LEXI=$O(@("^ICPT("_LEXI_")")) Q:+LEXI'>0 D
. N LEXD,LEXS,LEXE,LEXJ S LEXD=$P($G(^ICPT(+LEXI,0)),"^",6) S:LEXD="C" LEXT=LEXT+1 S:LEXD="H" LEXH=LEXH+1
. S LEXE=$O(^ICPT(+LEXI,60,"B"," "),-1) Q:LEXE'?7N
. S LEXJ=$O(^ICPT(+LEXI,60,"B",+LEXE," "),-1) Q:LEXJ'?1N.N
. S LEXS=$P($G(^ICPT(+LEXI,60,+LEXJ,0)),"^",2)
. S:LEXS>0&(LEXD="C") LEXA=LEXA+1 S:LEXS>0&(LEXD="H") LEXB=LEXB+1
S:LEXT>0 $P(^LEX(757.03,3,0),"^",6)=+LEXT S $P(^LEX(757.03,3,0),"^",5)=+LEXA
S:LEXH>0 $P(^LEX(757.03,4,0),"^",6)=+LEXH S $P(^LEX(757.03,4,0),"^",5)=+LEXB
N LEXTD,LEXFD S LEXTD=$$DT^XLFDT,LEXFD=$$FMADD^XLFDT(LEXTD,365)
K ^TMP("LEXXGI3",$J) S (LEXA,LEXT,LEXI)=0 F S LEXI=$O(^LEX(757.02,"ASRC","SCT",LEXI)) Q:+LEXI'>0 D
. N LEXC,LEXS S LEXC=$P($G(^LEX(757.02,+LEXI,0)),"^",2) Q:$D(^TMP("LEXXGI3",$J,(LEXC_" ")))
. S LEXT=LEXT+1 S LEXS=$$STATCHK^LEXSRC2(LEXC,LEXFD,,"SCT")
. S:+LEXS>0 LEXA=LEXA+1 S ^TMP("LEXXGI3",$J,(LEXC_" "))=""
K ^TMP("LEXXGI3",$J) S:LEXT>0 $P(^LEX(757.03,56,0),"^",6)=+LEXT S $P(^LEX(757.03,56,0),"^",5)=+LEXA
D:$D(LEXALL) OTH
Q
TOT ; Code Set Totals
N LEXT,LEXA,LEXC W:$L($G(IOF)) @IOF
W !,?2,"Code Set ",?27,$J("Active",6),?36,$J("Inactive",8),?49,$J(" Total",6)
W !,?2,"----------------------",?27,$J("------",6),?36,$J("--------",8),?49,$J(" -----",6)
S LEXT="ICD-9-CM Diagnosis ",LEXA=$P($G(^LEX(757.03,1,0)),"^",5),LEXC=$P($G(^LEX(757.03,1,0)),"^",6),LEXI=LEXC-LEXA
W !,?2,LEXT,?27,$J(LEXA,6),?36,$J(LEXI,8),?49,$J(LEXC,6)
S LEXT="ICD-9 Procedures ",LEXA=$P($G(^LEX(757.03,2,0)),"^",5),LEXC=$P($G(^LEX(757.03,2,0)),"^",6),LEXI=LEXC-LEXA
W !,?2,LEXT,?27,$J(LEXA,6),?36,$J(LEXI,8),?49,$J(LEXC,6)
S LEXT="ICD-10-CM Diagnosis ",LEXA=$P($G(^LEX(757.03,30,0)),"^",5),LEXC=$P($G(^LEX(757.03,30,0)),"^",6),LEXI=LEXC-LEXA
W !,?2,LEXT,?27,$J(LEXA,6),?36,$J(LEXI,8),?49,$J(LEXC,6)
S LEXT="ICD-10-CM Procedures ",LEXA=$P($G(^LEX(757.03,31,0)),"^",5),LEXC=$P($G(^LEX(757.03,31,0)),"^",6),LEXI=LEXC-LEXA
W !,?2,LEXT,?27,$J(LEXA,6),?36,$J(LEXI,8),?49,$J(LEXC,6)
S LEXT="CPT Procedures ",LEXA=$P($G(^LEX(757.03,3,0)),"^",5),LEXC=$P($G(^LEX(757.03,3,0)),"^",6),LEXI=LEXC-LEXA
W !,?2,LEXT,?27,$J(LEXA,6),?36,$J(LEXI,8),?49,$J(LEXC,6)
S LEXT="HCPCS Procedures ",LEXA=$P($G(^LEX(757.03,4,0)),"^",5),LEXC=$P($G(^LEX(757.03,4,0)),"^",6),LEXI=LEXC-LEXA
W !,?2,LEXT,?27,$J(LEXA,6),?36,$J(LEXI,8),?49,$J(LEXC,6)
S LEXT="SNOMED CT Codes ",LEXA=$P($G(^LEX(757.03,56,0)),"^",5),LEXC=$P($G(^LEX(757.03,56,0)),"^",6),LEXI=LEXC-LEXA
W !,?2,LEXT,?27,$J(LEXA,6),?36,$J(LEXI,8),?49,$J(LEXC,6),!
Q
OTH ; Other SAB Totals
N LEXCSI,LEXTD,LEXFD S LEXTD=$$DT^XLFDT,LEXFD=$$FMADD^XLFDT(LEXTD,365)
S LEXCSI=0 F S LEXCSI=$O(^LEX(757.03,+LEXCSI)) Q:+LEXCSI'>0 D
. N LEXSAB,LEXSCI,LEXTOT,LEXACT
. S LEXSAB=$E($G(^LEX(757.03,+LEXCSI,0)),1,3) Q:$L(LEXSAB)'=3
. Q:"^CPT^CPC^ICD^ICP^10D^10P^SCT^"[("^"_LEXSAB_"^")
. K ^TMP("LEXXGI3",$J,LEXSAB) S (LEXTOT,LEXACT,LEXSCI)=0
. F S LEXSCI=$O(^LEX(757.02,"ASRC",LEXSAB,LEXSCI)) Q:+LEXSCI'>0 D
. . N LEXCOD,LEXSTA
. . S LEXCOD=$P($G(^LEX(757.02,+LEXSCI,0)),"^",2) Q:'$L(LEXCOD)
. . Q:$D(^TMP("LEXXGI3",$J,LEXSAB,LEXCOD))
. . S LEXTOT=LEXTOT+1
. . S LEXSTA=$$STATCHK^LEXSRC2(LEXCOD,LEXFD,,LEXSAB)
. . S:+LEXSTA>0 LEXACT=LEXACT+1
. . S ^TMP("LEXXGI3",$J,LEXSAB,LEXCOD)=""
. S $P(^LEX(757.03,+LEXCSI,0),"^",5)=+LEXACT
. S $P(^LEX(757.03,+LEXCSI,0),"^",6)=+LEXTOT
. K ^TMP("LEXXGI3",$J,LEXSAB)
K ^TMP("LEXXGI3",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXXGI3 9848 printed Apr 23, 2025@18:24:25 Page 2
LEXXGI3 ;ISL/KER - Global Import (Load Data in ^LEXM) ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**59,80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEXM( N/A
+5 ;
+6 ; External References
+7 ; $$S^%ZTLOAD ICR 10063
+8 ; ^DIM ICR 10016
+9 ; $$ROOT^ICDEX ICR 5747
+10 ; $$DT^XLFDT ICR 10103
+11 ; $$FMTE^XLFDT ICR 10103
+12 ;
+13 ; Local Variables NEWed or KILLed Elsewhere
+14 ;
+15 ; LEXFL Array of Files
+16 ; LEXOK LEXM exist
+17 ; LEXSCHG Changes
+18 ; ZTQUEUED Queued Task
+19 ; ZTSK Task Number
+20 ;
FILES ; Load Data for all files
+1 if '$LENGTH($GET(LEXB))
QUIT
NEW LEXHDR,LEXBLD,LEXDAT,LEXFI,LEXFIC,LEXHDRS,LEXLOG,LEXINS,LEXTOTI,LEXTOTN,LEXPER,LEXPRE
+2 SET (LEXFI,LEXFIC,LEXHDR,LEXTOTI,LEXTOTN,LEXPER,LEXPRE)=0
SET LEXBLD=LEXB
+3 SET LEXDAT=$PIECE($GET(^LEXM(0,"VRRVDT")),"^",1)
SET LEXINS=1
+4 if +LEXDAT'>0
SET LEXDAT=$$DT^XLFDT
IF LEXOK
Begin DoDot:1
+5 NEW LEXCRE,LEXL1
SET LEXL1=""
SET LEXCRE=$GET(^LEXM(0,"CREATED"))
SET LEXCRE=$SELECT(+LEXCRE>0:($$MIX^LEXXGI2($$FMTE^XLFDT(LEXCRE))),1:"")
+6 if $LENGTH($PIECE(LEXCRE,"@",2))
SET LEXCRE=$PIECE(LEXCRE,"@",1)_" at "_$PIECE(LEXCRE,"@",2)
SET LEXL1=" Updating files "
+7 if $LENGTH($GET(LEXCRE))&($LENGTH($GET(LEXL1)))
SET LEXL1=$GET(LEXL1)_"using export global created "_$GET(LEXCRE)
+8 DO PB^LEXXGI2(LEXL1)
End DoDot:1
+9 SET LEXFI=0
FOR
SET LEXFI=$ORDER(^LEXM(LEXFI))
if +LEXFI=0
QUIT
SET LEXTOTN=+($GET(LEXTOTN))+($ORDER(^LEXM(LEXFI," "),-1))
+10 SET LEXFI=0
FOR
SET LEXFI=$ORDER(^LEXM(LEXFI))
if +LEXFI=0
QUIT
DO FILE
+11 QUIT
FILE ; Load Data for one file
+1 NEW LEXCF,LEXCHG,LEXCHGS,LEXCNT,LEXFIL,LEXI,LEXID,LEXIEN,LEXL,LEXLC
+2 NEW LEXMUMPS,LEXNM,LEXRT,LEXS,LEXTOT,LEXTXT,LEXIGL,LEXIGI,LEXIGF,LEXIGT
+3 NEW LEXIGD,LEXIGO,LEXBEG,LEXEND,LEXELP,LEXFB
+4 SET LEXFB=$GET(^LEXM(+LEXFI,0,"BUILD"))
SET LEXIGO=0
SET LEXBEG=$$HACK^LEXXGI2
+5 SET (LEXCNT,LEXLC,LEXI)=0
SET LEXL=68
SET LEXFIC=LEXFIC+1
IF LEXOK
Begin DoDot:1
+6 NEW LEXB,LEXFID,LEXNM,LEXVR,LEXRV,LEXDT,LEXL1,LEXL2
SET (LEXL1,LEXL2)=""
SET LEXFID=$PIECE(LEXFI,".",1)
+7 if +LEXFID'>0
QUIT
if $DATA(LEXHDRS(+LEXFID))
QUIT
SET LEXHDRS(LEXFID)=""
if +LEXFI=81!(+LEXFI=81.3)
SET LEXHDRS(81)=""
SET LEXHDRS(81.3)=""
+8 if LEXFID=80
SET LEXNM="ICD-9-CM"
if LEXFID=81
SET LEXNM="CPT-4/HCPCS"
if LEXFID=757
SET LEXNM="Lexicon"
SET LEXB=$GET(^LEXM(LEXFI,0,"BUILD"))
+9 SET LEXVR=$GET(^LEXM(LEXFI,0,"VR"))
SET LEXRV=$GET(^LEXM(LEXFI,0,"VRRV"))
SET LEXDT=$$MIX^LEXXGI2($$FMTE^XLFDT($PIECE(LEXRV,"^",2)))
SET LEXRV=$PIECE(LEXRV,"^",1)
+10 SET LEXL1="Updating "_LEXNM
if $LENGTH(LEXB)
SET LEXL1=LEXL1_" with patch/build "_LEXB
if $LENGTH(LEXVR)
SET LEXL2=" To version "_LEXVR
+11 if $LENGTH(LEXVR)&($LENGTH(LEXRV))
SET LEXL2=LEXL2_" revision "_LEXRV
if $LENGTH(LEXVR)&($LENGTH(LEXRV))&($LENGTH(LEXDT))
SET LEXL2=LEXL2_" dated "_LEXDT
+12 if $LENGTH(LEXL1)
SET LEXL1=" "_LEXL1
if $LENGTH(LEXL2)
SET LEXL2=" "_LEXL2
DO BL^LEXXGI2
if $LENGTH(LEXL1)
DO TL^LEXXGI2(LEXL1)
if $LENGTH(LEXL2)
DO TL^LEXXGI2(LEXL2)
DO BL^LEXXGI2
End DoDot:1
+13 SET LEXTOT=+($GET(^LEXM(LEXFI,0)))
if LEXTOT=0
GOTO FILEQ
+14 SET LEXNM=$GET(^LEXM(LEXFI,0,"NM"))
+15 IF $LENGTH(LEXNM)
IF $$UP^LEXXGI2(LEXNM)'["FILE"
SET LEXNM=LEXNM_" FILE"
+16 if $LENGTH(LEXNM)
SET LEXNM=$$MIX^LEXXGI2(LEXNM)
SET LEXCHG=$GET(^LEXM(LEXFI,0))
+17 SET LEXTXT=" "_LEXNM
SET LEXTXT=LEXTXT_$JUSTIFY("",(40-$LENGTH(LEXTXT)))_LEXFI
+18 if LEXFIC=1
DO PB^LEXXGI2(LEXTXT)
if LEXFIC'=1
DO TL^LEXXGI2(LEXTXT)
+19 SET LEXS=+(LEXTOT\LEXL)
if LEXS=0
SET LEXS=1
if +($ORDER(^LEXM(LEXFI,0)))>0
WRITE !," "
+20 DO UPCHG^LEXXGI2
FOR
SET LEXI=$ORDER(^LEXM(LEXFI,LEXI))
if +LEXI=0
QUIT
Begin DoDot:1
+21 SET LEXCNT=LEXCNT+1
SET LEXMUMPS=$GET(^LEXM(LEXFI,LEXI))
+22 IF LEXCNT'<LEXS
SET LEXLC=LEXLC+1
if LEXLC'>LEXL
WRITE "."
SET LEXCNT=0
+23 SET LEXRT=$PIECE(LEXMUMPS,"^",2)
SET LEXFIL=""
+24 if LEXMUMPS["^LEX("!(LEXMUMPS["^LEXT(")!(LEXMUMPS["^LEXC(")
SET LEXFIL=+($PIECE(LEXRT,"(",2))
SET LEXFL(+($PIECE(LEXRT,"(",2)))=""
+25 if LEXMUMPS[$$ROOT^ICDEX(80)
SET LEXFIL=80
SET LEXFL(80)=""
+26 if LEXMUMPS[$$ROOT^ICDEX(80.1)
SET LEXFIL=80.1
SET LEXFL(80.1)=""
+27 if LEXMUMPS["^ICPT("
SET LEXFIL=81
SET LEXFL(81)=""
+28 if LEXMUMPS["^DIC(81.3"
SET LEXFIL=81.3
SET LEXFL(81.3)=""
+29 if LEXMUMPS["^DIC(81.2"
SET LEXFIL=81.2
SET LEXFL(81.2)=""
+30 if +LEXFIL>0
SET LEXSCHG(+LEXFIL,0)=""
+31 IF $LENGTH(LEXMUMPS)
Begin DoDot:2
+32 XECUTE LEXMUMPS
SET LEXIGO=1
+33 SET LEXTOTI=+($GET(LEXTOTI))+1
IF +($GET(LEXTOTN))>0
IF +($GET(LEXTOTI))>0
IF $DATA(ZTQUEUED)
IF +($GET(ZTSK))>0
Begin DoDot:3
+34 NEW LEXT,LEXTSK
SET (LEXT,LEXPER)=(+($GET(LEXTOTI))/+($GET(LEXTOTN)))*100
if +LEXPER-(+($GET(LEXPRE)))'>2
QUIT
SET LEXPRE=+($GET(LEXPER))
+35 SET LEXPER=$JUSTIFY(LEXPER,6,2)
IF +LEXT>0
SET LEXPER=LEXPER_"% complete"
SET LEXTSK=$$S^%ZTLOAD(LEXPER)
End DoDot:3
End DoDot:2
End DoDot:1
+36 IF +($GET(LEXIGO))>0
Begin DoDot:1
+37 SET LEXEND=$$HACK^LEXXGI2
SET LEXELP=$$ELAP^LEXXGI2(LEXBEG,LEXEND)
if LEXELP=""
SET LEXELP="00:00:00"
End DoDot:1
FILEQ ; Load Data for one file - QUIT
+1 QUIT
UTOT ; CSV Totals
+1 NEW Y,ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSAVE,ZTQUEUED,ZTREQ
SET ZTRTN="UTOTS^LEXXGI3"
+2 SET ZTDESC="Update HIPAA CSV Totals in file 757.03"
if $DATA(LEXALL)
SET ZTSAVE("LEXALL")=""
+3 SET ZTIO=""
SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
DO HOME^%ZIS
KILL LEXALL
+4 QUIT
UTOTS ; CSV Totals
+1 NEW LEXA,LEXB,LEXD,LEXE,LEXH,LEXI,LEXS,LEXT,LEXTD,LEXFD
+2 SET (LEXI,LEXT,LEXA)=0
FOR
SET LEXI=$ORDER(@("^ICD9("_LEXI_")"))
if +LEXI'>0!(LEXI>499999)
QUIT
Begin DoDot:1
+3 NEW LEXE,LEXH,LEXS
SET LEXT=LEXT+1
+4 SET LEXE=$ORDER(@("^ICD9("_+LEXI_",66,""B"","" "")"),-1)
if LEXE'?7N
QUIT
+5 SET LEXH=$ORDER(@("^ICD9("_+LEXI_",66,""B"","_+LEXE_","" "")"),-1)
if LEXH'?1N.N
QUIT
+6 SET LEXS=+($PIECE($GET(@("^ICD9("_+LEXI_",66,"_+LEXH_",0)")),"^",2))
if +LEXS>0
SET LEXA=LEXA+1
End DoDot:1
+7 if LEXT>0
SET $PIECE(^LEX(757.03,1,0),"^",6)=+LEXT
SET $PIECE(^LEX(757.03,1,0),"^",5)=+LEXA
+8 SET (LEXI,LEXT,LEXA)=0
FOR
SET LEXI=$ORDER(@("^ICD0("_LEXI_")"))
if +LEXI'>0!(LEXI>499999)
QUIT
Begin DoDot:1
+9 NEW LEXE,LEXH,LEXS
SET LEXT=LEXT+1
+10 SET LEXE=$ORDER(@("^ICD0("_+LEXI_",66,""B"","" "")"),-1)
if LEXE'?7N
QUIT
+11 SET LEXH=$ORDER(@("^ICD0("_+LEXI_",66,""B"","_+LEXE_","" "")"),-1)
if LEXH'?1N.N
QUIT
+12 SET LEXS=+($PIECE($GET(@("^ICD0("_+LEXI_",66,"_+LEXH_",0)")),"^",2))
if +LEXS>0
SET LEXA=LEXA+1
End DoDot:1
+13 if LEXT>0
SET $PIECE(^LEX(757.03,2,0),"^",6)=+LEXT
SET $PIECE(^LEX(757.03,2,0),"^",5)=+LEXA
+14 SET LEXI=499999
SET (LEXA,LEXT)=0
FOR
SET LEXI=$ORDER(@("^ICD9("_LEXI_")"))
if +LEXI'>0
QUIT
Begin DoDot:1
+15 NEW LEXE,LEXH,LEXS
SET LEXT=LEXT+1
+16 SET LEXE=$ORDER(@("^ICD9("_+LEXI_",66,""B"","" "")"),-1)
if LEXE'?7N
QUIT
+17 SET LEXH=$ORDER(@("^ICD9("_+LEXI_",66,""B"","_+LEXE_","" "")"),-1)
if LEXH'?1N.N
QUIT
+18 SET LEXS=+($PIECE($GET(@("^ICD9("_+LEXI_",66,"_+LEXH_",0)")),"^",2))
if +LEXS>0
SET LEXA=LEXA+1
End DoDot:1
+19 if LEXT>0
SET $PIECE(^LEX(757.03,30,0),"^",6)=+LEXT
SET $PIECE(^LEX(757.03,30,0),"^",5)=+LEXA
+20 SET LEXI=499999
SET (LEXA,LEXT)=0
FOR
SET LEXI=$ORDER(@("^ICD0("_LEXI_")"))
if +LEXI'>0
QUIT
Begin DoDot:1
+21 NEW LEXE,LEXH,LEXS
SET LEXT=LEXT+1
+22 SET LEXE=$ORDER(@("^ICD0("_+LEXI_",66,""B"","" "")"),-1)
if LEXE'?7N
QUIT
+23 SET LEXH=$ORDER(@("^ICD0("_+LEXI_",66,""B"","_+LEXE_","" "")"),-1)
if LEXH'?1N.N
QUIT
+24 SET LEXS=+($PIECE($GET(@("^ICD0("_+LEXI_",66,"_+LEXH_",0)")),"^",2))
if +LEXS>0
SET LEXA=LEXA+1
End DoDot:1
+25 if LEXT>0
SET $PIECE(^LEX(757.03,31,0),"^",6)=+LEXT
SET $PIECE(^LEX(757.03,31,0),"^",5)=+LEXA
+26 SET (LEXI,LEXT,LEXH,LEXA,LEXB)=0
FOR
SET LEXI=$ORDER(@("^ICPT("_LEXI_")"))
if +LEXI'>0
QUIT
Begin DoDot:1
+27 NEW LEXD,LEXS,LEXE,LEXJ
SET LEXD=$PIECE($GET(^ICPT(+LEXI,0)),"^",6)
if LEXD="C"
SET LEXT=LEXT+1
if LEXD="H"
SET LEXH=LEXH+1
+28 SET LEXE=$ORDER(^ICPT(+LEXI,60,"B"," "),-1)
if LEXE'?7N
QUIT
+29 SET LEXJ=$ORDER(^ICPT(+LEXI,60,"B",+LEXE," "),-1)
if LEXJ'?1N.N
QUIT
+30 SET LEXS=$PIECE($GET(^ICPT(+LEXI,60,+LEXJ,0)),"^",2)
+31 if LEXS>0&(LEXD="C")
SET LEXA=LEXA+1
if LEXS>0&(LEXD="H")
SET LEXB=LEXB+1
End DoDot:1
+32 if LEXT>0
SET $PIECE(^LEX(757.03,3,0),"^",6)=+LEXT
SET $PIECE(^LEX(757.03,3,0),"^",5)=+LEXA
+33 if LEXH>0
SET $PIECE(^LEX(757.03,4,0),"^",6)=+LEXH
SET $PIECE(^LEX(757.03,4,0),"^",5)=+LEXB
+34 NEW LEXTD,LEXFD
SET LEXTD=$$DT^XLFDT
SET LEXFD=$$FMADD^XLFDT(LEXTD,365)
+35 KILL ^TMP("LEXXGI3",$JOB)
SET (LEXA,LEXT,LEXI)=0
FOR
SET LEXI=$ORDER(^LEX(757.02,"ASRC","SCT",LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+36 NEW LEXC,LEXS
SET LEXC=$PIECE($GET(^LEX(757.02,+LEXI,0)),"^",2)
if $DATA(^TMP("LEXXGI3",$JOB,(LEXC_" ")))
QUIT
+37 SET LEXT=LEXT+1
SET LEXS=$$STATCHK^LEXSRC2(LEXC,LEXFD,,"SCT")
+38 if +LEXS>0
SET LEXA=LEXA+1
SET ^TMP("LEXXGI3",$JOB,(LEXC_" "))=""
End DoDot:1
+39 KILL ^TMP("LEXXGI3",$JOB)
if LEXT>0
SET $PIECE(^LEX(757.03,56,0),"^",6)=+LEXT
SET $PIECE(^LEX(757.03,56,0),"^",5)=+LEXA
+40 if $DATA(LEXALL)
DO OTH
+41 QUIT
TOT ; Code Set Totals
+1 NEW LEXT,LEXA,LEXC
if $LENGTH($GET(IOF))
WRITE @IOF
+2 WRITE !,?2,"Code Set ",?27,$JUSTIFY("Active",6),?36,$JUSTIFY("Inactive",8),?49,$JUSTIFY(" Total",6)
+3 WRITE !,?2,"----------------------",?27,$JUSTIFY("------",6),?36,$JUSTIFY("--------",8),?49,$JUSTIFY(" -----",6)
+4 SET LEXT="ICD-9-CM Diagnosis "
SET LEXA=$PIECE($GET(^LEX(757.03,1,0)),"^",5)
SET LEXC=$PIECE($GET(^LEX(757.03,1,0)),"^",6)
SET LEXI=LEXC-LEXA
+5 WRITE !,?2,LEXT,?27,$JUSTIFY(LEXA,6),?36,$JUSTIFY(LEXI,8),?49,$JUSTIFY(LEXC,6)
+6 SET LEXT="ICD-9 Procedures "
SET LEXA=$PIECE($GET(^LEX(757.03,2,0)),"^",5)
SET LEXC=$PIECE($GET(^LEX(757.03,2,0)),"^",6)
SET LEXI=LEXC-LEXA
+7 WRITE !,?2,LEXT,?27,$JUSTIFY(LEXA,6),?36,$JUSTIFY(LEXI,8),?49,$JUSTIFY(LEXC,6)
+8 SET LEXT="ICD-10-CM Diagnosis "
SET LEXA=$PIECE($GET(^LEX(757.03,30,0)),"^",5)
SET LEXC=$PIECE($GET(^LEX(757.03,30,0)),"^",6)
SET LEXI=LEXC-LEXA
+9 WRITE !,?2,LEXT,?27,$JUSTIFY(LEXA,6),?36,$JUSTIFY(LEXI,8),?49,$JUSTIFY(LEXC,6)
+10 SET LEXT="ICD-10-CM Procedures "
SET LEXA=$PIECE($GET(^LEX(757.03,31,0)),"^",5)
SET LEXC=$PIECE($GET(^LEX(757.03,31,0)),"^",6)
SET LEXI=LEXC-LEXA
+11 WRITE !,?2,LEXT,?27,$JUSTIFY(LEXA,6),?36,$JUSTIFY(LEXI,8),?49,$JUSTIFY(LEXC,6)
+12 SET LEXT="CPT Procedures "
SET LEXA=$PIECE($GET(^LEX(757.03,3,0)),"^",5)
SET LEXC=$PIECE($GET(^LEX(757.03,3,0)),"^",6)
SET LEXI=LEXC-LEXA
+13 WRITE !,?2,LEXT,?27,$JUSTIFY(LEXA,6),?36,$JUSTIFY(LEXI,8),?49,$JUSTIFY(LEXC,6)
+14 SET LEXT="HCPCS Procedures "
SET LEXA=$PIECE($GET(^LEX(757.03,4,0)),"^",5)
SET LEXC=$PIECE($GET(^LEX(757.03,4,0)),"^",6)
SET LEXI=LEXC-LEXA
+15 WRITE !,?2,LEXT,?27,$JUSTIFY(LEXA,6),?36,$JUSTIFY(LEXI,8),?49,$JUSTIFY(LEXC,6)
+16 SET LEXT="SNOMED CT Codes "
SET LEXA=$PIECE($GET(^LEX(757.03,56,0)),"^",5)
SET LEXC=$PIECE($GET(^LEX(757.03,56,0)),"^",6)
SET LEXI=LEXC-LEXA
+17 WRITE !,?2,LEXT,?27,$JUSTIFY(LEXA,6),?36,$JUSTIFY(LEXI,8),?49,$JUSTIFY(LEXC,6),!
+18 QUIT
OTH ; Other SAB Totals
+1 NEW LEXCSI,LEXTD,LEXFD
SET LEXTD=$$DT^XLFDT
SET LEXFD=$$FMADD^XLFDT(LEXTD,365)
+2 SET LEXCSI=0
FOR
SET LEXCSI=$ORDER(^LEX(757.03,+LEXCSI))
if +LEXCSI'>0
QUIT
Begin DoDot:1
+3 NEW LEXSAB,LEXSCI,LEXTOT,LEXACT
+4 SET LEXSAB=$EXTRACT($GET(^LEX(757.03,+LEXCSI,0)),1,3)
if $LENGTH(LEXSAB)'=3
QUIT
+5 if "^CPT^CPC^ICD^ICP^10D^10P^SCT^"[("^"_LEXSAB_"^")
QUIT
+6 KILL ^TMP("LEXXGI3",$JOB,LEXSAB)
SET (LEXTOT,LEXACT,LEXSCI)=0
+7 FOR
SET LEXSCI=$ORDER(^LEX(757.02,"ASRC",LEXSAB,LEXSCI))
if +LEXSCI'>0
QUIT
Begin DoDot:2
+8 NEW LEXCOD,LEXSTA
+9 SET LEXCOD=$PIECE($GET(^LEX(757.02,+LEXSCI,0)),"^",2)
if '$LENGTH(LEXCOD)
QUIT
+10 if $DATA(^TMP("LEXXGI3",$JOB,LEXSAB,LEXCOD))
QUIT
+11 SET LEXTOT=LEXTOT+1
+12 SET LEXSTA=$$STATCHK^LEXSRC2(LEXCOD,LEXFD,,LEXSAB)
+13 if +LEXSTA>0
SET LEXACT=LEXACT+1
+14 SET ^TMP("LEXXGI3",$JOB,LEXSAB,LEXCOD)=""
End DoDot:2
+15 SET $PIECE(^LEX(757.03,+LEXCSI,0),"^",5)=+LEXACT
+16 SET $PIECE(^LEX(757.03,+LEXCSI,0),"^",6)=+LEXTOT
+17 KILL ^TMP("LEXXGI3",$JOB,LEXSAB)
End DoDot:1
+18 KILL ^TMP("LEXXGI3",$JOB)
+19 QUIT
