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

LEXQVSEA.m

Go to the documentation of this file.
  1. LEXQVSEA ;ISL/TJH - Query - VA Extension SNOMED CT - Ask ;01/25/2021
  1. ;;2.0;LEXICON UTILITY;**133**;Sep 23, 1996;Build 3
  1. ;
  1. ; Global Variables
  1. ; ^LEX(757.01, SACC 1.3
  1. ; ^LEX(757.02, SACC 1.3
  1. ;
  1. ; External References
  1. ; ^DIC ICR 10006
  1. ; $$DT^XLFDT ICR 10103
  1. ; $$FMTE^XLFDT ICR 10103
  1. ;
  1. Q
  1. SCT(X) ; SNOMED CT Code Selection
  1. ;
  1. ; Output 7 piece "^" delimited String
  1. ;
  1. ; 1 Code IEN file 757.02
  1. ; 2 Code
  1. ; 3 Status (1/0)
  1. ; 4 Effective date of Status
  1. ; 5 Initial Activation Date
  1. ; 6 Expression IEN file 757.01
  1. ; 7 Expression
  1. ;
  1. Q:+($G(LEXEXIT))>0 "^^"
  1. N DIC,DTOUT,DUOUT,LEXCP,LEXSO,LEXSAB,LEXSRC,LEXIEN,LEXND,LEXEIEN,LEXETXT,LEXVTXT
  1. N LEXVDT,Y S U="^",DIC(0)="AEQMZ",DIC="^LEX(757.02,",DIC("A")=" Select a SNOMED CT code: "
  1. S DIC("S")="I $P($G(^LEX(757.02,+Y,0)),U,3)=58&($P($G(^LEX(757.02,+Y,0)),U,5)>0)"
  1. S DIC("W")="W $$CODEW^LEXQVSEA(+Y)" W ! D ^DIC
  1. S:$G(X)["^^"!($D(DTOUT)) LEXEXIT=1 Q:$G(X)["^^"!(+($G(LEXEXIT))>0) "^^"
  1. Q:'$L($G(X))!($G(X)="^") "^" Q:$G(X)["^^" "^^" Q:$D(DTOUT)!($D(DUOUT)) "^"
  1. S LEXIEN=+Y,LEXND=$G(^LEX(757.02,+LEXIEN,0)),LEXEIEN=+LEXND
  1. S LEXSO=$P($G(LEXND),U,2),LEXSRC=$P($G(LEXND),U,3),LEXSAB=$P($G(^LEX(757.03,+LEXSRC,0)),U,1)
  1. S X="" I $L(LEXSO),$L(LEXSAB) S X=$$CODEDAT(LEXSO,$G(LEXCDT),LEXSAB)
  1. Q X
  1. CODEW(X) ; SNOMED CT Code Write
  1. Q:$G(DIC)'="^LEX(757.02," "" N IEN,COD,EFF,HIS,STA,ACT,EXP,PRE,PRI,NOD,QUA,STR S IEN=+($G(X)),(ACT,PRE,PRI,QUA)=""
  1. S NOD=$G(^LEX(757.02,+IEN,0)),EXP=$G(^LEX(757.01,+NOD,0)),EFF=$O(^LEX(757.02,+IEN,4,"B"," "),-1)
  1. S HIS=$O(^LEX(757.02,+IEN,4,"B",+EFF," "),-1),STA=$P($G(^LEX(757.02,+IEN,4,+HIS,0)),"^",2) S COD=$P(NOD,"^",2)
  1. S:STA="0" ACT="Inactive" S:$P(NOD,"^",5)>0 PRE="Preferred" S:$P(NOD,"^",7)>0 PRI="Primary"
  1. S:$L(ACT) QUA=QUA_", "_ACT S:$L(PRE) QUA=QUA_", "_PRE S:$L(PRI) QUA=QUA_", "_PRI
  1. F Q:$E(QUA,1)'=","&($E(QUA,1)'=" ") S QUA=$E(QUA,2,$L(QUA))
  1. S:$L(QUA) QUA="("_QUA_")" S STR=" "_COD_" (SCT)" S:$L(QUA) STR=STR_" "_QUA S X=STR
  1. Q X
  1. CODEDAT(X,Y,Z) ;
  1. ;
  1. ; Input
  1. ;
  1. ; X Code
  1. ; Y Versioning date
  1. ; Z Source Abbreviation (SAB)
  1. ;
  1. ; Output
  1. ;
  1. ; X 7 Piece "^" delimited string
  1. ; 1 Code IEN file 757.02
  1. ; 2 Code
  1. ; 3 Status (internal)
  1. ; 4 Effective date (internal)
  1. ; 5 Initial date (internal)
  1. ; 6 Expression IEN
  1. ; 7 Expression
  1. ;
  1. N LEXCD,LEXEF,LEXEN,LEXIA,LEXND,LEXSAB,LEXSN,LEXSO,LEXSRC,LEXST,LEXSTAT,LEXTX,LEXVDT
  1. S LEXSO=$G(X) Q:'$L(LEXSO) "1" S LEXVDT=$G(Y),LEXSAB=$$UP^XLFSTR($G(Z)) Q:$L(LEXSAB)'=3 "2"
  1. S LEXSRC=$O(^LEX(757.03,"ASAB",LEXSAB,0)) Q:+LEXSRC'>0 "3" S:LEXVDT'?7N LEXVDT=$$DT^XLFDT
  1. S LEXSTAT=$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,LEXSAB)
  1. S LEXST=$P(LEXSTAT,U,1) Q:"^0^1^"'[("^"_LEXST_"^") "4"
  1. S LEXSN=$P($G(LEXSTAT),U,2) Q:+LEXSN'>0 "5" Q:$P($G(^LEX(757.02,+LEXSN,0)),U,3)'=LEXSRC "6"
  1. S LEXND=$G(^LEX(757.02,+LEXSN,0)) Q:'$L(LEXND) "7"
  1. S LEXEN=+$P(LEXND,U,1) Q:+LEXEN'>0 "8"
  1. S LEXCD=$P(LEXND,U,2) Q:'$L(LEXCD) "9" Q:LEXCD'=$G(LEXSO) "A"
  1. S LEXEF=$P($G(LEXSTAT),U,3) S:LEXEF'?7N LEXEF="Pending"
  1. S LEXIA=$P($G(LEXSTAT),U,4)
  1. S LEXTX=$P($G(^LEX(757.01,+LEXEN,0)),U,1) Q:'$L(LEXTX) "B"
  1. S X=LEXSN_U_LEXCD_U_LEXST_U_LEXEF_U_LEXIA_U_LEXEN_U_LEXTX
  1. Q X
  1. SD(X) ; Short Date
  1. Q $TR($$FMTE^XLFDT(+($G(X)),"5DZ"),"@"," ")
  1. CLR ; Clear
  1. N LEXCDT,LEXCPT,LEXEXIT
  1. Q