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 Dec 13, 2024@02:08:45 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
