- LEXQHLM ;ISL/KER - Query History - Extract Misc ;05/23/2017
- ;;2.0;LEXICON UTILITY;**62,80,103**;Sep 23, 1996;Build 2
- ;
- ; Global Variables
- ; ^TMP("LEXQHO") SACC 2.3.2.5.1
- ;
- ; External References
- ; $$ROOT^ICDEX ICR 5747
- ; $$FMTE^XLFDT ICR 10103
- ;
- Q
- ; Miscellaneous
- BL ; Blank Line
- D TL(" ")
- Q
- TL(X) ; Text Line
- I $D(LEXTEST) W !,$G(X) Q
- N LEXI S LEXI=$O(^TMP("LEXQHO",$J," "),-1)+1,^TMP("LEXQHO",$J,LEXI)=$G(X),^TMP("LEXQHO",$J,0)=LEXI
- Q
- SD(X) ; Short Date
- Q $TR($$FMTE^XLFDT(+($G(X)),"5DZ"),"@"," ")
- IA(X) ; Initial Activation
- N LEXEF,LEXH,LEXN,LEXS,LEXE,LEXIEN,LEXRT,LEXARY S LEXIEN=+($G(X)),LEXE="" Q:+LEXIEN'>0 ""
- S LEXRT=$$ROOT^ICDEX(80.1) M LEXARY=@(LEXRT_+LEXIEN_",66)") Q:'$D(LEXARY(0)) ""
- S LEXEF="" F S LEXEF=$O(LEXARY("B",LEXEF)) Q:'$L(LEXEF) D Q:$G(LEXE)?7N
- . S LEXH=0 F S LEXH=$O(LEXARY("B",LEXEF,LEXH)) Q:+LEXH'>0 D
- . . S LEXN=$G(LEXARY(+LEXH,0)) S:+($P(LEXN,U,2))>0 LEXE=$P(LEXN,U,1) Q:$G(LEXE)?7N
- S X="" S:$G(LEXE)?7N X=$G(LEXE)
- Q X
- MS(X,Y) ; Date Message
- Q:$G(X)'>2781001&($G(Y)=0) " (business rule date used)"
- Q:$G(X)'>2890101&($G(Y)=1) " (business rule date used)"
- Q ""
- HD(X) ; Header
- Q:+($G(X))=1 "Status" Q:+($G(X))=2 "Operation/Procedure" Q:+($G(X))=3 "Description" Q:+($G(X))=4 "Major Diagnostic Category/DRG Groups"
- Q ""
- AND(X) ; Substitute 'and'
- S X=$G(X) Q:$L(X,", ")'>1 X
- S X=$P(X,", ",1,($L(X,", ")-1))_" and "_$P(X,", ",$L(X,", "))
- Q X
- CS(X) ; Trim Comma/Space
- S X=$$TM($G(X),","),X=$$TM($G(X)," "),X=$$TM($G(X),","),X=$$TM($G(X)," ")
- Q X
- CL ; Clear
- K LEXTEST
- Q X
- TM(X,Y) ; Trim Character Y - Default " "
- S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" "
- F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
- F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
- Q X
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQHLM 1854 printed Feb 18, 2025@23:34:49 Page 2
- LEXQHLM ;ISL/KER - Query History - Extract Misc ;05/23/2017
- +1 ;;2.0;LEXICON UTILITY;**62,80,103**;Sep 23, 1996;Build 2
- +2 ;
- +3 ; Global Variables
- +4 ; ^TMP("LEXQHO") SACC 2.3.2.5.1
- +5 ;
- +6 ; External References
- +7 ; $$ROOT^ICDEX ICR 5747
- +8 ; $$FMTE^XLFDT ICR 10103
- +9 ;
- +10 QUIT
- +11 ; Miscellaneous
- BL ; Blank Line
- +1 DO TL(" ")
- +2 QUIT
- TL(X) ; Text Line
- +1 IF $DATA(LEXTEST)
- WRITE !,$GET(X)
- QUIT
- +2 NEW LEXI
- SET LEXI=$ORDER(^TMP("LEXQHO",$JOB," "),-1)+1
- SET ^TMP("LEXQHO",$JOB,LEXI)=$GET(X)
- SET ^TMP("LEXQHO",$JOB,0)=LEXI
- +3 QUIT
- SD(X) ; Short Date
- +1 QUIT $TRANSLATE($$FMTE^XLFDT(+($GET(X)),"5DZ"),"@"," ")
- IA(X) ; Initial Activation
- +1 NEW LEXEF,LEXH,LEXN,LEXS,LEXE,LEXIEN,LEXRT,LEXARY
- SET LEXIEN=+($GET(X))
- SET LEXE=""
- if +LEXIEN'>0
- QUIT ""
- +2 SET LEXRT=$$ROOT^ICDEX(80.1)
- MERGE LEXARY=@(LEXRT_+LEXIEN_",66)")
- if '$DATA(LEXARY(0))
- QUIT ""
- +3 SET LEXEF=""
- FOR
- SET LEXEF=$ORDER(LEXARY("B",LEXEF))
- if '$LENGTH(LEXEF)
- QUIT
- Begin DoDot:1
- +4 SET LEXH=0
- FOR
- SET LEXH=$ORDER(LEXARY("B",LEXEF,LEXH))
- if +LEXH'>0
- QUIT
- Begin DoDot:2
- +5 SET LEXN=$GET(LEXARY(+LEXH,0))
- if +($PIECE(LEXN,U,2))>0
- SET LEXE=$PIECE(LEXN,U,1)
- if $GET(LEXE)?7N
- QUIT
- End DoDot:2
- End DoDot:1
- if $GET(LEXE)?7N
- QUIT
- +6 SET X=""
- if $GET(LEXE)?7N
- SET X=$GET(LEXE)
- +7 QUIT X
- MS(X,Y) ; Date Message
- +1 if $GET(X)'>2781001&($GET(Y)=0)
- QUIT " (business rule date used)"
- +2 if $GET(X)'>2890101&($GET(Y)=1)
- QUIT " (business rule date used)"
- +3 QUIT ""
- HD(X) ; Header
- +1 if +($GET(X))=1
- QUIT "Status"
- if +($GET(X))=2
- QUIT "Operation/Procedure"
- if +($GET(X))=3
- QUIT "Description"
- if +($GET(X))=4
- QUIT "Major Diagnostic Category/DRG Groups"
- +2 QUIT ""
- AND(X) ; Substitute 'and'
- +1 SET X=$GET(X)
- if $LENGTH(X,", ")'>1
- QUIT X
- +2 SET X=$PIECE(X,", ",1,($LENGTH(X,", ")-1))_" and "_$PIECE(X,", ",$LENGTH(X,", "))
- +3 QUIT X
- CS(X) ; Trim Comma/Space
- +1 SET X=$$TM($GET(X),",")
- SET X=$$TM($GET(X)," ")
- SET X=$$TM($GET(X),",")
- SET X=$$TM($GET(X)," ")
- +2 QUIT X
- CL ; Clear
- +1 KILL LEXTEST
- +2 QUIT X
- TM(X,Y) ; Trim Character Y - Default " "
- +1 SET X=$GET(X)
- if X=""
- QUIT X
- SET Y=$GET(Y)
- if '$LENGTH(Y)
- SET Y=" "
- +2 FOR
- if $EXTRACT(X,1)'=Y
- QUIT
- SET X=$EXTRACT(X,2,$LENGTH(X))
- +3 FOR
- if $EXTRACT(X,$LENGTH(X))'=Y
- QUIT
- SET X=$EXTRACT(X,1,($LENGTH(X)-1))
- +4 QUIT X