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