LEXQM ;ISL/KER - Query - Miscellaneous ;05/23/2017
;;2.0;LEXICON UTILITY;**62,80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; None
;
; External References
; HOME^%ZIS ICR 10086
; $$GET1^DIQ ICR 2056
; ^DIR ICR 10026
; $$DT^XLFDT ICR 10103
; $$FMADD^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed Elsewhere
; LEXEXIT Exit Flag
;
AD(X) ; Assumed Date
Q:+($G(LEXEXIT))>0 "^^" N DIR,DIRUT,DIROUT,DTOUT,DUOUT,DIRB,LEXPAS,LEXNOW,LEXFUT,Y
S LEXNOW=$$UP^XLFSTR($$FMTE^XLFDT($$DT^XLFDT)),LEXPAS=2760101,LEXFUT=$$FMADD^XLFDT($$DT^XLFDT,(365*5))
S DIRB=$$RET^LEXQD("LEXQM","AD",+($G(DUZ)),"Assumed Date") S:'$L(DIRB) DIRB=LEXNOW S:$L($G(LEXAD)) DIRB=""
S:$L(DIRB) DIR("B")=DIRB S DIR("A")=" Assumed Date of Service: "
S DIR(0)="DAO^"_LEXPAS_":"_LEXFUT_":EX",(DIR("?"),DIR("??"))="^D ADH^LEXQM"
S DIR("PRE")="S:X[""?"" X=""??"""
W ! D ^DIR S:X["^^"!($D(DTOUT)) X="^^",LEXEXIT=1 Q:X["^^"!(+($G(LEXEXIT))>0) "^^" Q:X["^" "^"
S X="" S:$E(Y,1,7)?7N X=$$UP^XLFSTR($$FMTE^XLFDT($E(Y,1,7)))_"^"_$E(Y,1,7)
D:$L($P(X,"^",1)) SAV^LEXQD("LEXQM","AD",+($G(DUZ)),"Assumed Date",$P(X,"^",1))
Q X
ADH ; Assumed Date Help
W !,?5,"This is the date of a fictitious healthcare transaction. It is the"
W !,?5,"date that service was provided to a patient and the date that will "
W !,?5,"be used during the lookup of a code (ICD/CPT/CPT Modifier)."
I $L($G(LEXFUT)),$G(LEXFUT)?7N D
. W !!,?5,"Enter a date from ",$$UP^XLFSTR($$FMTE^XLFDT(LEXPAS))," to ",$$UP^XLFSTR($$FMTE^XLFDT(LEXFUT))," or"
. W !,?5,"T (for TODAY), T+1 (for TOMORROW), T+2, T+7, etc.",!,?5,"T-1 (for YESTERDAY), T-3W (for 3 WEEKS AGO), etc."
Q
;
CSD(X) ; Code Set Date
Q:+($G(LEXEXIT))>0 "^^" N DIR,DIRUT,DIROUT,DTOUT,DUOUT,DIRB,LEXPAS,LEXNOW,LEXFUT,Y
S LEXNOW=$$UP^XLFSTR($$FMTE^XLFDT($$DT^XLFDT)),LEXPAS=2760101,LEXFUT=$$FMADD^XLFDT($$DT^XLFDT,(365*2)) S:LEXFUT?7N LEXFUT=$E(LEXFUT,1,3)_"1001"
S DIRB=$$RET^LEXQD("LEXQM","CSD",+($G(DUZ)),"Code Set Date") S:'$L(DIRB) DIRB=LEXNOW S:$L($G(LEXAD)) DIRB=""
S:$L(DIRB) DIR("B")=DIRB S DIR("A")=" Enter Code Set Update Date: "
S DIR(0)="DAO^"_LEXPAS_":"_LEXFUT_":EX",(DIR("?"),DIR("??"))="^D CSDH^LEXQM",DIR("PRE")="S X=$$CSDX^LEXQM(X)"
W ! D ^DIR S:X["^^"!($D(DTOUT)) X="^^",LEXEXIT=1 Q:X["^^"!(+($G(LEXEXIT))>0) "^^" Q:X["^" "^"
S X="" S:$E(Y,1,7)?7N X=$$UP^XLFSTR($$FMTE^XLFDT($E(Y,1,7)))_"^"_$E(Y,1,7)
D:$L($P(X,"^",1)) SAV^LEXQD("LEXQM","CSD",+($G(DUZ)),"Code Set Date",$P(X,"^",1))
Q X
CSDH ; Code Set Date Help
W !,?3,"This is a date to used to search for Code Set changes in the ICD and CPT"
W !,?3,"files. A future date may be used to search for changes in the Code Sets"
W !,?3,"with future effective dates. (HINT: Most Code Set effective dates are"
W !,?3,"quarterly, the first of January, April, July or October)"
I $L($G(LEXFUT)),$G(LEXFUT)?7N D
. W !!,?5,"Enter a date from ",$$UP^XLFSTR($$FMTE^XLFDT(LEXPAS))," to ",$$UP^XLFSTR($$FMTE^XLFDT(LEXFUT))," or"
. W !,?5,"T (for TODAY), T+1 (for TOMORROW), T+2, T+7, etc."
. W !,?5,"T-1 (for YESTERDAY), T-3W (for 3 WEEKS AGO), etc."
. W !,?5,"Q1 (for first quarter), Q109 (for first quarter of FY09), etc."
Q
CSDX(X) ; Code Set Date Pre-Processing
Q:$G(X)["?" "??" N LEXN,LEXY,LEXT,LEXX,LEXQ,LEXF S LEXN=$$DT^XLFDT,LEXY=$E(LEXN,1,3),LEXT=LEXY+1700 S:+($E(LEXN,4,5))>9 LEXY=LEXY+1
Q:X="Q2" (LEXY_"0101") Q:X="Q3" (LEXY_"0401") Q:X="Q4" (LEXY_"0701") Q:X="Q1" ((LEXY-1)_"1001")
S LEXX="" I $E(X,1)="Q",$E(X,2,4)?3N D
. N LEXQ,LEXF S LEXQ=$E(X,2),LEXF=$E(X,3,4) S:LEXF>70 LEXF="19"_LEXF S:LEXF'>70 LEXF="20"_LEXF S:LEXQ=1 LEXF=LEXF-1
. S LEXQ=$S(+LEXQ=1:"1001",+LEXQ=2:"0101",+LEXQ=3:"0401",+LEXQ=4:"0701",1:"") Q:'$L(LEXQ)
. S:LEXF?4N&(LEXF>1976)&(LEXF<(+($G(LEXT))+3))&(LEXQ?4N) LEXX=(LEXF-1700)_LEXQ
S:$L(LEXX) X=LEXX
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
;
; Miscellaneous
ATTR ; Screen Attributes
N X S X="IOINHI;IOINORM" D ENDR^%ZISS S BOLD=$G(IOINHI),NORM=$G(IOINORM)
Q
KATTR ; Kill Screen Attributes
D KILL^%ZISS K IOINHI,IOINORM,BOLD,NORM
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
SD(X) ; Short Date
Q $TR($$FMTE^XLFDT(+($G(X)),"5DZ"),"@"," ")
ED(X) ; External Date
Q:+($G(X))'>0 "--/--/----"
Q $TR($$FMTE^XLFDT(+($G(X)),"5DZ"),"@"," ")
ES(X) ; External Status
Q $S(+($G(X))="1":"Active",$G(X)="0":"Inactive",1:"")
CLR ; Clear
N LEXAD,LEXEXIT
Q
EV(X) ; Check environment
N LEX S DT=$$DT^XLFDT D HOME^%ZIS S U="^" I +($G(DUZ))=0 W !!,?5,"DUZ not defined" Q 0
S LEX=$$GET1^DIQ(200,(DUZ_","),.01) I '$L(LEX) W !!,?5,"DUZ not valid" Q 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQM 5196 printed Sep 23, 2025@19:44:52 Page 2
LEXQM ;ISL/KER - Query - Miscellaneous ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**62,80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; None
+5 ;
+6 ; External References
+7 ; HOME^%ZIS ICR 10086
+8 ; $$GET1^DIQ ICR 2056
+9 ; ^DIR ICR 10026
+10 ; $$DT^XLFDT ICR 10103
+11 ; $$FMADD^XLFDT ICR 10103
+12 ; $$FMTE^XLFDT ICR 10103
+13 ; $$UP^XLFSTR ICR 10104
+14 ;
+15 ; Local Variables NEWed or KILLed Elsewhere
+16 ; LEXEXIT Exit Flag
+17 ;
AD(X) ; Assumed Date
+1 if +($GET(LEXEXIT))>0
QUIT "^^"
NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT,DIRB,LEXPAS,LEXNOW,LEXFUT,Y
+2 SET LEXNOW=$$UP^XLFSTR($$FMTE^XLFDT($$DT^XLFDT))
SET LEXPAS=2760101
SET LEXFUT=$$FMADD^XLFDT($$DT^XLFDT,(365*5))
+3 SET DIRB=$$RET^LEXQD("LEXQM","AD",+($GET(DUZ)),"Assumed Date")
if '$LENGTH(DIRB)
SET DIRB=LEXNOW
if $LENGTH($GET(LEXAD))
SET DIRB=""
+4 if $LENGTH(DIRB)
SET DIR("B")=DIRB
SET DIR("A")=" Assumed Date of Service: "
+5 SET DIR(0)="DAO^"_LEXPAS_":"_LEXFUT_":EX"
SET (DIR("?"),DIR("??"))="^D ADH^LEXQM"
+6 SET DIR("PRE")="S:X[""?"" X=""??"""
+7 WRITE !
DO ^DIR
if X["^^"!($DATA(DTOUT))
SET X="^^"
SET LEXEXIT=1
if X["^^"!(+($GET(LEXEXIT))>0)
QUIT "^^"
if X["^"
QUIT "^"
+8 SET X=""
if $EXTRACT(Y,1,7)?7N
SET X=$$UP^XLFSTR($$FMTE^XLFDT($EXTRACT(Y,1,7)))_"^"_$EXTRACT(Y,1,7)
+9 if $LENGTH($PIECE(X,"^",1))
DO SAV^LEXQD("LEXQM","AD",+($GET(DUZ)),"Assumed Date",$PIECE(X,"^",1))
+10 QUIT X
ADH ; Assumed Date Help
+1 WRITE !,?5,"This is the date of a fictitious healthcare transaction. It is the"
+2 WRITE !,?5,"date that service was provided to a patient and the date that will "
+3 WRITE !,?5,"be used during the lookup of a code (ICD/CPT/CPT Modifier)."
+4 IF $LENGTH($GET(LEXFUT))
IF $GET(LEXFUT)?7N
Begin DoDot:1
+5 WRITE !!,?5,"Enter a date from ",$$UP^XLFSTR($$FMTE^XLFDT(LEXPAS))," to ",$$UP^XLFSTR($$FMTE^XLFDT(LEXFUT))," or"
+6 WRITE !,?5,"T (for TODAY), T+1 (for TOMORROW), T+2, T+7, etc.",!,?5,"T-1 (for YESTERDAY), T-3W (for 3 WEEKS AGO), etc."
End DoDot:1
+7 QUIT
+8 ;
CSD(X) ; Code Set Date
+1 if +($GET(LEXEXIT))>0
QUIT "^^"
NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT,DIRB,LEXPAS,LEXNOW,LEXFUT,Y
+2 SET LEXNOW=$$UP^XLFSTR($$FMTE^XLFDT($$DT^XLFDT))
SET LEXPAS=2760101
SET LEXFUT=$$FMADD^XLFDT($$DT^XLFDT,(365*2))
if LEXFUT?7N
SET LEXFUT=$EXTRACT(LEXFUT,1,3)_"1001"
+3 SET DIRB=$$RET^LEXQD("LEXQM","CSD",+($GET(DUZ)),"Code Set Date")
if '$LENGTH(DIRB)
SET DIRB=LEXNOW
if $LENGTH($GET(LEXAD))
SET DIRB=""
+4 if $LENGTH(DIRB)
SET DIR("B")=DIRB
SET DIR("A")=" Enter Code Set Update Date: "
+5 SET DIR(0)="DAO^"_LEXPAS_":"_LEXFUT_":EX"
SET (DIR("?"),DIR("??"))="^D CSDH^LEXQM"
SET DIR("PRE")="S X=$$CSDX^LEXQM(X)"
+6 WRITE !
DO ^DIR
if X["^^"!($DATA(DTOUT))
SET X="^^"
SET LEXEXIT=1
if X["^^"!(+($GET(LEXEXIT))>0)
QUIT "^^"
if X["^"
QUIT "^"
+7 SET X=""
if $EXTRACT(Y,1,7)?7N
SET X=$$UP^XLFSTR($$FMTE^XLFDT($EXTRACT(Y,1,7)))_"^"_$EXTRACT(Y,1,7)
+8 if $LENGTH($PIECE(X,"^",1))
DO SAV^LEXQD("LEXQM","CSD",+($GET(DUZ)),"Code Set Date",$PIECE(X,"^",1))
+9 QUIT X
CSDH ; Code Set Date Help
+1 WRITE !,?3,"This is a date to used to search for Code Set changes in the ICD and CPT"
+2 WRITE !,?3,"files. A future date may be used to search for changes in the Code Sets"
+3 WRITE !,?3,"with future effective dates. (HINT: Most Code Set effective dates are"
+4 WRITE !,?3,"quarterly, the first of January, April, July or October)"
+5 IF $LENGTH($GET(LEXFUT))
IF $GET(LEXFUT)?7N
Begin DoDot:1
+6 WRITE !!,?5,"Enter a date from ",$$UP^XLFSTR($$FMTE^XLFDT(LEXPAS))," to ",$$UP^XLFSTR($$FMTE^XLFDT(LEXFUT))," or"
+7 WRITE !,?5,"T (for TODAY), T+1 (for TOMORROW), T+2, T+7, etc."
+8 WRITE !,?5,"T-1 (for YESTERDAY), T-3W (for 3 WEEKS AGO), etc."
+9 WRITE !,?5,"Q1 (for first quarter), Q109 (for first quarter of FY09), etc."
End DoDot:1
+10 QUIT
CSDX(X) ; Code Set Date Pre-Processing
+1 if $GET(X)["?"
QUIT "??"
NEW LEXN,LEXY,LEXT,LEXX,LEXQ,LEXF
SET LEXN=$$DT^XLFDT
SET LEXY=$EXTRACT(LEXN,1,3)
SET LEXT=LEXY+1700
if +($EXTRACT(LEXN,4,5))>9
SET LEXY=LEXY+1
+2 if X="Q2"
QUIT (LEXY_"0101")
if X="Q3"
QUIT (LEXY_"0401")
if X="Q4"
QUIT (LEXY_"0701")
if X="Q1"
QUIT ((LEXY-1)_"1001")
+3 SET LEXX=""
IF $EXTRACT(X,1)="Q"
IF $EXTRACT(X,2,4)?3N
Begin DoDot:1
+4 NEW LEXQ,LEXF
SET LEXQ=$EXTRACT(X,2)
SET LEXF=$EXTRACT(X,3,4)
if LEXF>70
SET LEXF="19"_LEXF
if LEXF'>70
SET LEXF="20"_LEXF
if LEXQ=1
SET LEXF=LEXF-1
+5 SET LEXQ=$SELECT(+LEXQ=1:"1001",+LEXQ=2:"0101",+LEXQ=3:"0401",+LEXQ=4:"0701",1:"")
if '$LENGTH(LEXQ)
QUIT
+6 if LEXF?4N&(LEXF>1976)&(LEXF<(+($GET(LEXT))+3))&(LEXQ?4N)
SET LEXX=(LEXF-1700)_LEXQ
End DoDot:1
+7 if $LENGTH(LEXX)
SET X=LEXX
+8 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=" "
FOR
if $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 FOR
if $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+3 QUIT X
+4 ;
+5 ; Miscellaneous
ATTR ; Screen Attributes
+1 NEW X
SET X="IOINHI;IOINORM"
DO ENDR^%ZISS
SET BOLD=$GET(IOINHI)
SET NORM=$GET(IOINORM)
+2 QUIT
KATTR ; Kill Screen Attributes
+1 DO KILL^%ZISS
KILL IOINHI,IOINORM,BOLD,NORM
+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
SD(X) ; Short Date
+1 QUIT $TRANSLATE($$FMTE^XLFDT(+($GET(X)),"5DZ"),"@"," ")
ED(X) ; External Date
+1 if +($GET(X))'>0
QUIT "--/--/----"
+2 QUIT $TRANSLATE($$FMTE^XLFDT(+($GET(X)),"5DZ"),"@"," ")
ES(X) ; External Status
+1 QUIT $SELECT(+($GET(X))="1":"Active",$GET(X)="0":"Inactive",1:"")
CLR ; Clear
+1 NEW LEXAD,LEXEXIT
+2 QUIT
EV(X) ; Check environment
+1 NEW LEX
SET DT=$$DT^XLFDT
DO HOME^%ZIS
SET U="^"
IF +($GET(DUZ))=0
WRITE !!,?5,"DUZ not defined"
QUIT 0
+2 SET LEX=$$GET1^DIQ(200,(DUZ_","),.01)
IF '$LENGTH(LEX)
WRITE !!,?5,"DUZ not valid"
QUIT 0
+3 QUIT 1
