LEXQVSEA ;ISL/TJH - Query - VA Extension SNOMED CT - Ask ;01/25/2021
;;2.0;LEXICON UTILITY;**133**;Sep 23, 1996;Build 3
;
; Global Variables
; ^LEX(757.01, SACC 1.3
; ^LEX(757.02, SACC 1.3
;
; External References
; ^DIC ICR 10006
; $$DT^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
;
Q
SCT(X) ; SNOMED CT Code Selection
;
; Output 7 piece "^" delimited String
;
; 1 Code IEN file 757.02
; 2 Code
; 3 Status (1/0)
; 4 Effective date of Status
; 5 Initial Activation Date
; 6 Expression IEN file 757.01
; 7 Expression
;
Q:+($G(LEXEXIT))>0 "^^"
N DIC,DTOUT,DUOUT,LEXCP,LEXSO,LEXSAB,LEXSRC,LEXIEN,LEXND,LEXEIEN,LEXETXT,LEXVTXT
N LEXVDT,Y S U="^",DIC(0)="AEQMZ",DIC="^LEX(757.02,",DIC("A")=" Select a SNOMED CT code: "
S DIC("S")="I $P($G(^LEX(757.02,+Y,0)),U,3)=58&($P($G(^LEX(757.02,+Y,0)),U,5)>0)"
S DIC("W")="W $$CODEW^LEXQVSEA(+Y)" W ! D ^DIC
S:$G(X)["^^"!($D(DTOUT)) LEXEXIT=1 Q:$G(X)["^^"!(+($G(LEXEXIT))>0) "^^"
Q:'$L($G(X))!($G(X)="^") "^" Q:$G(X)["^^" "^^" Q:$D(DTOUT)!($D(DUOUT)) "^"
S LEXIEN=+Y,LEXND=$G(^LEX(757.02,+LEXIEN,0)),LEXEIEN=+LEXND
S LEXSO=$P($G(LEXND),U,2),LEXSRC=$P($G(LEXND),U,3),LEXSAB=$P($G(^LEX(757.03,+LEXSRC,0)),U,1)
S X="" I $L(LEXSO),$L(LEXSAB) S X=$$CODEDAT(LEXSO,$G(LEXCDT),LEXSAB)
Q X
CODEW(X) ; SNOMED CT Code Write
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)=""
S NOD=$G(^LEX(757.02,+IEN,0)),EXP=$G(^LEX(757.01,+NOD,0)),EFF=$O(^LEX(757.02,+IEN,4,"B"," "),-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)
S:STA="0" ACT="Inactive" S:$P(NOD,"^",5)>0 PRE="Preferred" S:$P(NOD,"^",7)>0 PRI="Primary"
S:$L(ACT) QUA=QUA_", "_ACT S:$L(PRE) QUA=QUA_", "_PRE S:$L(PRI) QUA=QUA_", "_PRI
F Q:$E(QUA,1)'=","&($E(QUA,1)'=" ") S QUA=$E(QUA,2,$L(QUA))
S:$L(QUA) QUA="("_QUA_")" S STR=" "_COD_" (SCT)" S:$L(QUA) STR=STR_" "_QUA S X=STR
Q X
CODEDAT(X,Y,Z) ;
;
; Input
;
; X Code
; Y Versioning date
; Z Source Abbreviation (SAB)
;
; Output
;
; X 7 Piece "^" delimited string
; 1 Code IEN file 757.02
; 2 Code
; 3 Status (internal)
; 4 Effective date (internal)
; 5 Initial date (internal)
; 6 Expression IEN
; 7 Expression
;
N LEXCD,LEXEF,LEXEN,LEXIA,LEXND,LEXSAB,LEXSN,LEXSO,LEXSRC,LEXST,LEXSTAT,LEXTX,LEXVDT
S LEXSO=$G(X) Q:'$L(LEXSO) "1" S LEXVDT=$G(Y),LEXSAB=$$UP^XLFSTR($G(Z)) Q:$L(LEXSAB)'=3 "2"
S LEXSRC=$O(^LEX(757.03,"ASAB",LEXSAB,0)) Q:+LEXSRC'>0 "3" S:LEXVDT'?7N LEXVDT=$$DT^XLFDT
S LEXSTAT=$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,LEXSAB)
S LEXST=$P(LEXSTAT,U,1) Q:"^0^1^"'[("^"_LEXST_"^") "4"
S LEXSN=$P($G(LEXSTAT),U,2) Q:+LEXSN'>0 "5" Q:$P($G(^LEX(757.02,+LEXSN,0)),U,3)'=LEXSRC "6"
S LEXND=$G(^LEX(757.02,+LEXSN,0)) Q:'$L(LEXND) "7"
S LEXEN=+$P(LEXND,U,1) Q:+LEXEN'>0 "8"
S LEXCD=$P(LEXND,U,2) Q:'$L(LEXCD) "9" Q:LEXCD'=$G(LEXSO) "A"
S LEXEF=$P($G(LEXSTAT),U,3) S:LEXEF'?7N LEXEF="Pending"
S LEXIA=$P($G(LEXSTAT),U,4)
S LEXTX=$P($G(^LEX(757.01,+LEXEN,0)),U,1) Q:'$L(LEXTX) "B"
S X=LEXSN_U_LEXCD_U_LEXST_U_LEXEF_U_LEXIA_U_LEXEN_U_LEXTX
Q X
SD(X) ; Short Date
Q $TR($$FMTE^XLFDT(+($G(X)),"5DZ"),"@"," ")
CLR ; Clear
N LEXCDT,LEXCPT,LEXEXIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQVSEA 3575 printed Oct 16, 2024@18:09:48 Page 2
LEXQVSEA ;ISL/TJH - Query - VA Extension SNOMED CT - Ask ;01/25/2021
+1 ;;2.0;LEXICON UTILITY;**133**;Sep 23, 1996;Build 3
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.01, SACC 1.3
+5 ; ^LEX(757.02, SACC 1.3
+6 ;
+7 ; External References
+8 ; ^DIC ICR 10006
+9 ; $$DT^XLFDT ICR 10103
+10 ; $$FMTE^XLFDT ICR 10103
+11 ;
+12 QUIT
SCT(X) ; SNOMED CT Code Selection
+1 ;
+2 ; Output 7 piece "^" delimited String
+3 ;
+4 ; 1 Code IEN file 757.02
+5 ; 2 Code
+6 ; 3 Status (1/0)
+7 ; 4 Effective date of Status
+8 ; 5 Initial Activation Date
+9 ; 6 Expression IEN file 757.01
+10 ; 7 Expression
+11 ;
+12 if +($GET(LEXEXIT))>0
QUIT "^^"
+13 NEW DIC,DTOUT,DUOUT,LEXCP,LEXSO,LEXSAB,LEXSRC,LEXIEN,LEXND,LEXEIEN,LEXETXT,LEXVTXT
+14 NEW LEXVDT,Y
SET U="^"
SET DIC(0)="AEQMZ"
SET DIC="^LEX(757.02,"
SET DIC("A")=" Select a SNOMED CT code: "
+15 SET DIC("S")="I $P($G(^LEX(757.02,+Y,0)),U,3)=58&($P($G(^LEX(757.02,+Y,0)),U,5)>0)"
+16 SET DIC("W")="W $$CODEW^LEXQVSEA(+Y)"
WRITE !
DO ^DIC
+17 if $GET(X)["^^"!($DATA(DTOUT))
SET LEXEXIT=1
if $GET(X)["^^"!(+($GET(LEXEXIT))>0)
QUIT "^^"
+18 if '$LENGTH($GET(X))!($GET(X)="^")
QUIT "^"
if $GET(X)["^^"
QUIT "^^"
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT "^"
+19 SET LEXIEN=+Y
SET LEXND=$GET(^LEX(757.02,+LEXIEN,0))
SET LEXEIEN=+LEXND
+20 SET LEXSO=$PIECE($GET(LEXND),U,2)
SET LEXSRC=$PIECE($GET(LEXND),U,3)
SET LEXSAB=$PIECE($GET(^LEX(757.03,+LEXSRC,0)),U,1)
+21 SET X=""
IF $LENGTH(LEXSO)
IF $LENGTH(LEXSAB)
SET X=$$CODEDAT(LEXSO,$GET(LEXCDT),LEXSAB)
+22 QUIT X
CODEW(X) ; SNOMED CT Code Write
+1 if $GET(DIC)'="^LEX(757.02,"
QUIT ""
NEW IEN,COD,EFF,HIS,STA,ACT,EXP,PRE,PRI,NOD,QUA,STR
SET IEN=+($GET(X))
SET (ACT,PRE,PRI,QUA)=""
+2 SET NOD=$GET(^LEX(757.02,+IEN,0))
SET EXP=$GET(^LEX(757.01,+NOD,0))
SET EFF=$ORDER(^LEX(757.02,+IEN,4,"B"," "),-1)
+3 SET HIS=$ORDER(^LEX(757.02,+IEN,4,"B",+EFF," "),-1)
SET STA=$PIECE($GET(^LEX(757.02,+IEN,4,+HIS,0)),"^",2)
SET COD=$PIECE(NOD,"^",2)
+4 if STA="0"
SET ACT="Inactive"
if $PIECE(NOD,"^",5)>0
SET PRE="Preferred"
if $PIECE(NOD,"^",7)>0
SET PRI="Primary"
+5 if $LENGTH(ACT)
SET QUA=QUA_", "_ACT
if $LENGTH(PRE)
SET QUA=QUA_", "_PRE
if $LENGTH(PRI)
SET QUA=QUA_", "_PRI
+6 FOR
if $EXTRACT(QUA,1)'=","&($EXTRACT(QUA,1)'=" ")
QUIT
SET QUA=$EXTRACT(QUA,2,$LENGTH(QUA))
+7 if $LENGTH(QUA)
SET QUA="("_QUA_")"
SET STR=" "_COD_" (SCT)"
if $LENGTH(QUA)
SET STR=STR_" "_QUA
SET X=STR
+8 QUIT X
CODEDAT(X,Y,Z) ;
+1 ;
+2 ; Input
+3 ;
+4 ; X Code
+5 ; Y Versioning date
+6 ; Z Source Abbreviation (SAB)
+7 ;
+8 ; Output
+9 ;
+10 ; X 7 Piece "^" delimited string
+11 ; 1 Code IEN file 757.02
+12 ; 2 Code
+13 ; 3 Status (internal)
+14 ; 4 Effective date (internal)
+15 ; 5 Initial date (internal)
+16 ; 6 Expression IEN
+17 ; 7 Expression
+18 ;
+19 NEW LEXCD,LEXEF,LEXEN,LEXIA,LEXND,LEXSAB,LEXSN,LEXSO,LEXSRC,LEXST,LEXSTAT,LEXTX,LEXVDT
+20 SET LEXSO=$GET(X)
if '$LENGTH(LEXSO)
QUIT "1"
SET LEXVDT=$GET(Y)
SET LEXSAB=$$UP^XLFSTR($GET(Z))
if $LENGTH(LEXSAB)'=3
QUIT "2"
+21 SET LEXSRC=$ORDER(^LEX(757.03,"ASAB",LEXSAB,0))
if +LEXSRC'>0
QUIT "3"
if LEXVDT'?7N
SET LEXVDT=$$DT^XLFDT
+22 SET LEXSTAT=$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,LEXSAB)
+23 SET LEXST=$PIECE(LEXSTAT,U,1)
if "^0^1^"'[("^"_LEXST_"^")
QUIT "4"
+24 SET LEXSN=$PIECE($GET(LEXSTAT),U,2)
if +LEXSN'>0
QUIT "5"
if $PIECE($GET(^LEX(757.02,+LEXSN,0)),U,3)'=LEXSRC
QUIT "6"
+25 SET LEXND=$GET(^LEX(757.02,+LEXSN,0))
if '$LENGTH(LEXND)
QUIT "7"
+26 SET LEXEN=+$PIECE(LEXND,U,1)
if +LEXEN'>0
QUIT "8"
+27 SET LEXCD=$PIECE(LEXND,U,2)
if '$LENGTH(LEXCD)
QUIT "9"
if LEXCD'=$GET(LEXSO)
QUIT "A"
+28 SET LEXEF=$PIECE($GET(LEXSTAT),U,3)
if LEXEF'?7N
SET LEXEF="Pending"
+29 SET LEXIA=$PIECE($GET(LEXSTAT),U,4)
+30 SET LEXTX=$PIECE($GET(^LEX(757.01,+LEXEN,0)),U,1)
if '$LENGTH(LEXTX)
QUIT "B"
+31 SET X=LEXSN_U_LEXCD_U_LEXST_U_LEXEF_U_LEXIA_U_LEXEN_U_LEXTX
+32 QUIT X
SD(X) ; Short Date
+1 QUIT $TRANSLATE($$FMTE^XLFDT(+($GET(X)),"5DZ"),"@"," ")
CLR ; Clear
+1 NEW LEXCDT,LEXCPT,LEXEXIT
+2 QUIT
