- 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
