- 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 Feb 18, 2025@23:35:10 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