Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LEXQC3

LEXQC3.m

Go to the documentation of this file.
  1. LEXQC3 ;ISL/KER - Query - Changes - ICD/ICP/10D/10P ;05/23/2017
  1. ;;2.0;LEXICON UTILITY;**80,103**;Sep 23, 1996;Build 2
  1. ;
  1. ; Global Variables
  1. ; ^TMP("LEXQC") SACC 2.3.2.5.1
  1. ;
  1. ; External References
  1. ; $$FILE^ICDEX ICR 5747
  1. ; $$ROOT^ICDEX ICR 5747
  1. ; $$SINFO^ICDEX ICR 5747
  1. ;
  1. ; Local Variables NEWed in LEXQC
  1. ; LEXADT After Date
  1. ; LEXBDT Before Date
  1. ; LEXCDT Versioning Date
  1. ; LEXQLEN Length of Display
  1. ; LEXQSTR Length of String
  1. ; LEXQTOT Total Records
  1. ;
  1. D09 ; ICD-9 Diagnosis Changes
  1. D CK("80",1)
  1. Q
  1. P09 ; ICD-9 Procedure Changes
  1. D CK("80.1",2)
  1. Q
  1. D10 ; ICD-10 Diagnosis Changes
  1. D CK("80",30)
  1. Q
  1. P10 ; ICD-10 Procedure Changes
  1. D CK("80.1",31)
  1. Q
  1. CK(X,Y) ; Check File X for Changes
  1. N LEXFI,LEXRT,LEXSAB,LEXIDT,LEXSYS,LEXSINF S LEXFI=$$FILE^ICDEX($G(X)) Q:+LEXFI'>0
  1. S LEXRT=$$ROOT^ICDEX(LEXFI) Q:$E(LEXRT,1)'="^" Q:$E(LEXRT,$L(LEXRT))'="(" Q:'$L($P($P(LEXRT,"^",2),"(",1))
  1. S LEXSYS=+($G(Y)) Q:+LEXSYS'>0 S LEXSINF=$$SINFO^ICDEX(LEXSYS)
  1. S LEXSAB=$P(LEXSINF,"^",3) Q:'$L(LEXSAB) S LEXIDT=$P(LEXSINF,"^",5)
  1. S LEXCDT=$G(LEXCDT) Q:LEXCDT'?7N Q:LEXCDT<LEXIDT Q:$P($G(LEXBDT),".",1)'?7N
  1. Q:$P($G(LEXADT),".",1)'?7N Q:+LEXCDT'>+LEXBDT K ^TMP("LEXQC",$J,LEXSAB) N LEX1,LEX2,LEX3
  1. N LEX4,LEX5,LEX6,LEXAEF,LEXAST,LEXBEF,LEXBST,LEXCEF,LEXCNT,LEXCST
  1. N LEXH,LEXIEN,LEXLC,LEXND,LEXORD,LEXPEF,LEXPST,LEXQL,LEXSO,LEXSTID
  1. S LEXQLEN=+($G(LEXQLEN)),LEXQTOT=+($G(LEXQTOT))
  1. S LEXQSTR=+($G(LEXQSTR)),LEXCNT=0,LEXLC=0
  1. S LEXORD="" F S LEXORD=$O(@(LEXRT_"""ABA"","_+LEXSYS_","""_LEXORD_""")")) Q:'$L(LEXORD) D
  1. . S LEXIEN=0 F S LEXIEN=$O(@(LEXRT_"""ABA"","_+LEXSYS_","""_LEXORD_""","_+LEXIEN_")")) Q:+LEXIEN'>0 D CE
  1. D:$D(^TMP("LEXQC",$J,LEXSAB)) UPC(LEXSAB)
  1. Q
  1. CE ; Check Entry
  1. Q:'$L($G(LEXRT)) Q:+($G(LEXIEN))'>0
  1. N LEX1,LEX2,LEX3,LEX4,LEX5,LEX6,LEX7,LEX8,LEXAEF,LEXAST,LEXBEF
  1. N LEXBST,LEXCEF,LEXCST,LEXH,LEXND,LEXPEF,LEXPST,LEXQL,LEXSO,LEXSTID
  1. S LEXCNT=LEXCNT+1 I LEXCNT'<+($G(LEXQSTR)) S LEXLC=+($G(LEXLC))+1 D
  1. . W:'$D(ZTQUEUED)&('$D(LEXQUIET))&(LEXLC'>+($G(LEXQLEN))) "." S LEXCNT=0
  1. S LEXSO=$P($G(@(LEXRT_+LEXIEN_",0)")),"^",1) Q:'$L(LEXSO)
  1. S LEXH=$O(@(LEXRT_+LEXIEN_",66,""B"","_+LEXCDT_","" "")"),-1)
  1. S LEXND=$G(@(LEXRT_+LEXIEN_",66,"_+LEXH_",0)"))
  1. S LEXCEF=$P(LEXND,"^",1),LEXCST=$P(LEXND,"^",2)
  1. S LEXH=$O(@(LEXRT_+LEXIEN_",66,""B"","_+LEXBDT_","" "")"),-1)
  1. S LEXND=$G(@(LEXRT_+LEXIEN_",66,"_+LEXH_",0)"))
  1. S LEXBEF=$P(LEXND,"^",1),LEXBST=$P(LEXND,"^",2)
  1. S LEXH=$O(@(LEXRT_+LEXIEN_",66,""B"","_+LEXADT_","" "")"),-1)
  1. S LEXND=$G(@(LEXRT_+LEXIEN_",66,"_+LEXH_",0)"))
  1. S LEXAEF=$P(LEXND,"^",1),LEXAST=$P(LEXND,"^",2)
  1. S LEXH=$O(@(LEXRT_+LEXIEN_",66,""B"","_+LEXCDT_")"),-1)
  1. S LEXH=$O(@(LEXRT_+LEXIEN_",66,""B"","_+LEXH_","" "")"),-1)
  1. S LEXND=$G(@(LEXRT_+LEXIEN_",66,"_+LEXH_",0)"))
  1. S LEXPEF=$P(LEXND,"^",1),LEXPST=$P(LEXND,"^",2)
  1. S LEX1=$D(@(LEXRT_+LEXIEN_",67,""B"","_+LEXCDT_")"))>0
  1. S LEX2=$D(@(LEXRT_+LEXIEN_",68,""B"","_+LEXCDT_")"))>0
  1. S LEX3=$O(@(LEXRT_+LEXIEN_",67,""B"","_+LEXCDT_")"),-1)
  1. S LEX4=$O(@(LEXRT_+LEXIEN_",68,""B"","_+LEXCDT_")"),-1)
  1. S LEX5=$D(@(LEXRT_+LEXIEN_",67,""B"","_+LEXCDT_")"))
  1. S LEX6=$D(@(LEXRT_+LEXIEN_",68,""B"","_+LEXCDT_")"))
  1. ; Short IEN Dupe
  1. S LEX7=$O(@(LEXRT_+LEXIEN_",67,""B"","_+LEXCDT_","" "")"),-1),LEX7=$$DUPS^LEXQC5(81,LEXIEN,LEX7)
  1. ; Long IEN Dupe
  1. S LEX8=$O(@(LEXRT_+LEXIEN_",68,""B"","_+LEXCDT_","" "")"),-1),LEX8=$$DUPL^LEXQC5(81,LEXIEN,LEX8)
  1. ; Activiation/Inactiviation/Re-Activation
  1. ; Has a current status and effective date
  1. ; Has a previous status and effective date
  1. ; Current status not equal to previous status
  1. ; Has a short description
  1. ; Has a long description
  1. ; Activation - current status >0
  1. ; Inactivatin - current status =0
  1. ; Reactivation - current status >0 past status =0
  1. S LEXQL=0 I $L(LEXCST),$L(LEXCEF) D
  1. . N LEXCT,LEXO Q:$L(LEXBEF)&($L(LEXBST))&(LEXBST'=LEXCST)
  1. . Q:$L(LEXAEF)&($L(LEXAST))&(LEXAST'=LEXCST)
  1. . Q:(LEX1>0&(LEX3?7N))!(LEX2>0&(LEX4?7N))
  1. . N LEXSTID Q:'$L($G(LEXSO)) S LEXSTID=$S(+LEXCST>0:"ACT",1:"INA")
  1. . S LEXQL=1 I LEXSTID="ACT",$G(LEXPEF)?7N,+($G(LEXPST))'>0 D
  1. . . I +($G(LEX5))'>0,+($G(LEX6))'>0 S LEXSTID="REA"
  1. . S LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT
  1. . S LEXCT=+($G(^TMP("LEXQC",$J,LEXSAB,LEXSTID,0)))
  1. . S:'$D(^TMP("LEXQC",$J,LEXSAB,LEXSTID,1,(LEXSO_" "))) LEXCT=LEXCT+1
  1. . S ^TMP("LEXQC",$J,LEXSAB,LEXSTID,1,(LEXSO_" "))=LEXO
  1. . S ^TMP("LEXQC",$J,LEXSAB,LEXSTID,0)=LEXCT
  1. ; I Previous status (LEXPST) >0 and
  1. ; Short exist (LEX1) with a previous short (LEX3) and not a duplicate (LEX7) or
  1. ; long exist (LEX2) with a previous long (LEX4) and not a duplicate (LEX8)
  1. I 'LEXQL I +LEXPST>0,((LEX1>0&(LEX3?7N)&(LEX7'>0))!(LEX2>0&(LEX4?7N)&(LEX8'>0))) D
  1. . N LEXCT,LEXO Q:'$L($G(LEXSO)) S LEXQL=1
  1. . S LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT
  1. . S LEXCT=+($G(^TMP("LEXQC",$J,LEXSAB,"REV",0)))
  1. . S:'$D(^TMP("LEXQC",$J,LEXSAB,"REV",1,(LEXSO_" "))) LEXCT=LEXCT+1
  1. . S ^TMP("LEXQC",$J,LEXSAB,"REV",1,(LEXSO_" "))=LEXO
  1. . S ^TMP("LEXQC",$J,LEXSAB,"REV",0)=LEXCT
  1. ; Current status (LEXCST) exist and active
  1. ; Previous Status (LEXPST) exist and is active
  1. ; Short exist (LEX1) with a previous short (LEX3) and not a duplicate (LEX7) or
  1. ; long exist (LEX2) with a previous long (LEX4) and not a duplicate (LEX8)
  1. I 'LEXQL S LEXQL=0 I ((LEXCEF?7N&(LEXCST>0))!(LEXPEF?7N&(LEXPST>0))),((LEX1>0&(LEX3?7N)&(LEX7'>0))!(LEX2>0&(LEX4?7N)&(LEX8'>0))) D
  1. . N LEXCT,LEXO S LEXQL=1
  1. . S LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT
  1. . S LEXCT=+($G(^TMP("LEXQC",$J,LEXSAB,"REU",0)))
  1. . S:'$D(^TMP("LEXQC",$J,LEXSAB,"REU",1,(LEXSO_" "))) LEXCT=LEXCT+1
  1. . S ^TMP("LEXQC",$J,LEXSAB,"REU",1,(LEXSO_" "))=LEXO
  1. . S ^TMP("LEXQC",$J,LEXSAB,"REU",0)=LEXCT
  1. I 'LEXQL I $D(@(LEXRT_+LEXIEN_",69,""B"","_+($G(LEXCDT))_")")) D
  1. . N LEXCT,LEXO S LEXQL=1
  1. . S LEXO=LEXIEN_"^"_LEXSO_"^"_LEXCDT
  1. . S LEXCT=+($G(^TMP("LEXQC",$J,LEXSAB,"UPD",0)))
  1. . S:'$D(^TMP("LEXQC",$J,LEXSAB,"UPD",1,(LEXSO_" "))) LEXCT=LEXCT+1
  1. . S ^TMP("LEXQC",$J,LEXSAB,"UPD",1,(LEXSO_" "))=LEXO
  1. . S ^TMP("LEXQC",$J,LEXSAB,"UPD",0)=LEXCT
  1. N LEXQUIET
  1. Q
  1. UPC(X) ; Update Counters
  1. N LEXSID,LEXACT,LEXORD,LEXCT S LEXSID=$G(X) Q:'$L(LEXSID)
  1. S LEXACT="" F S LEXACT=$O(^TMP("LEXQC",$J,LEXSID,LEXACT)) Q:'$L(LEXACT) D
  1. . S LEXCT=0,LEXORD="" F S LEXORD=$O(^TMP("LEXQC",$J,LEXSID,LEXACT,1,LEXORD)) Q:'$L(LEXORD) S LEXCT=LEXCT+1
  1. . S ^TMP("LEXQC",$J,LEXSID,LEXACT,0)=LEXCT
  1. Q