- LEXQHLM ;ISL/KER - Query History - Extract Misc ;04/21/2014
- ;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 10
- ;
- ; Global Variables
- ; ^TMP("LEXQHO") SACC 2.3.2.5.1
- ; ^UTILITY($J ICR 10011
- ;
- ; External References
- ; ^DIWP ICR 10011
- ; $$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 ""
- PR(LEX,X) ; Parse Array
- N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,LEXI,LEXLEN,LEXC K ^UTILITY($J,"W") Q:'$D(LEX)
- S LEXLEN=+($G(X)) S:+LEXLEN'>0 LEXLEN=79 S LEXC=+($G(LEX)) S:+($G(LEXC))'>0 LEXC=$O(LEX(" "),-1) Q:+LEXC'>0
- S DIWL=1,DIWF="C"_+LEXLEN S LEXI=0 F S LEXI=$O(LEX(LEXI)) Q:+LEXI=0 S X=$G(LEX(LEXI)) D ^DIWP
- K LEX S (LEXC,LEXI)=0 F S LEXI=$O(^UTILITY($J,"W",1,LEXI)) Q:+LEXI=0 D
- . S LEX(LEXI)=$$TM($G(^UTILITY($J,"W",1,LEXI,0))," "),LEXC=LEXC+1
- S:$L(LEXC) LEX=LEXC K ^UTILITY($J,"W")
- 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
- LEXQHLM ;ISL/KER - Query History - Extract Misc ;04/21/2014
- +1 ;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 10
- +2 ;
- +3 ; Global Variables
- +4 ; ^TMP("LEXQHO") SACC 2.3.2.5.1
- +5 ; ^UTILITY($J ICR 10011
- +6 ;
- +7 ; External References
- +8 ; ^DIWP ICR 10011
- +9 ; $$ROOT^ICDEX ICR 5747
- +10 ; $$FMTE^XLFDT ICR 10103
- +11 ;
- +12 QUIT
- +13 ; 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 ""
- PR(LEX,X) ; Parse Array
- +1 NEW DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,LEXI,LEXLEN,LEXC
- KILL ^UTILITY($JOB,"W")
- IF '$DATA(LEX)
- QUIT
- +2 SET LEXLEN=+($GET(X))
- IF +LEXLEN'>0
- SET LEXLEN=79
- SET LEXC=+($GET(LEX))
- IF +($GET(LEXC))'>0
- SET LEXC=$ORDER(LEX(" "),-1)
- IF +LEXC'>0
- QUIT
- +3 SET DIWL=1
- SET DIWF="C"_+LEXLEN
- SET LEXI=0
- FOR
- SET LEXI=$ORDER(LEX(LEXI))
- IF +LEXI=0
- QUIT
- SET X=$GET(LEX(LEXI))
- DO ^DIWP
- +4 KILL LEX
- SET (LEXC,LEXI)=0
- FOR
- SET LEXI=$ORDER(^UTILITY($JOB,"W",1,LEXI))
- IF +LEXI=0
- QUIT
- Begin DoDot:1
- +5 SET LEX(LEXI)=$$TM($GET(^UTILITY($JOB,"W",1,LEXI,0))," ")
- SET LEXC=LEXC+1
- End DoDot:1
- +6 IF $LENGTH(LEXC)
- SET LEX=LEXC
- KILL ^UTILITY($JOB,"W")
- +7 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
