Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LEXQM

LEXQM.m

Go to the documentation of this file.
  1. LEXQM ;ISL/KER - Query - Miscellaneous ;05/23/2017
  1. ;;2.0;LEXICON UTILITY;**62,80,103**;Sep 23, 1996;Build 2
  1. ;
  1. ; Global Variables
  1. ; None
  1. ;
  1. ; External References
  1. ; HOME^%ZIS ICR 10086
  1. ; $$GET1^DIQ ICR 2056
  1. ; ^DIR ICR 10026
  1. ; $$DT^XLFDT ICR 10103
  1. ; $$FMADD^XLFDT ICR 10103
  1. ; $$FMTE^XLFDT ICR 10103
  1. ; $$UP^XLFSTR ICR 10104
  1. ;
  1. ; Local Variables NEWed or KILLed Elsewhere
  1. ; LEXEXIT Exit Flag
  1. ;
  1. Q:+($G(LEXEXIT))>0 "^^" N DIR,DIRUT,DIROUT,DTOUT,DUOUT,DIRB,LEXPAS,LEXNOW,LEXFUT,Y
  1. S LEXNOW=$$UP^XLFSTR($$FMTE^XLFDT($$DT^XLFDT)),LEXPAS=2760101,LEXFUT=$$FMADD^XLFDT($$DT^XLFDT,(365*5))
  1. S DIRB=$$RET^LEXQD("LEXQM","AD",+($G(DUZ)),"Assumed Date") S:'$L(DIRB) DIRB=LEXNOW S:$L($G(LEXAD)) DIRB=""
  1. S:$L(DIRB) DIR("B")=DIRB S DIR("A")=" Assumed Date of Service: "
  1. S DIR(0)="DAO^"_LEXPAS_":"_LEXFUT_":EX",(DIR("?"),DIR("??"))="^D ADH^LEXQM"
  1. S DIR("PRE")="S:X[""?"" X=""??"""
  1. W ! D ^DIR S:X["^^"!($D(DTOUT)) X="^^",LEXEXIT=1 Q:X["^^"!(+($G(LEXEXIT))>0) "^^" Q:X["^" "^"
  1. S X="" S:$E(Y,1,7)?7N X=$$UP^XLFSTR($$FMTE^XLFDT($E(Y,1,7)))_"^"_$E(Y,1,7)
  1. D:$L($P(X,"^",1)) SAV^LEXQD("LEXQM","AD",+($G(DUZ)),"Assumed Date",$P(X,"^",1))
  1. Q X
  1. ADH ; Assumed Date Help
  1. W !,?5,"This is the date of a fictitious healthcare transaction. It is the"
  1. W !,?5,"date that service was provided to a patient and the date that will "
  1. W !,?5,"be used during the lookup of a code (ICD/CPT/CPT Modifier)."
  1. I $L($G(LEXFUT)),$G(LEXFUT)?7N D
  1. . W !!,?5,"Enter a date from ",$$UP^XLFSTR($$FMTE^XLFDT(LEXPAS))," to ",$$UP^XLFSTR($$FMTE^XLFDT(LEXFUT))," or"
  1. . 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."
  1. Q
  1. ;
  1. CSD(X) ; Code Set Date
  1. Q:+($G(LEXEXIT))>0 "^^" N DIR,DIRUT,DIROUT,DTOUT,DUOUT,DIRB,LEXPAS,LEXNOW,LEXFUT,Y
  1. 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"
  1. S DIRB=$$RET^LEXQD("LEXQM","CSD",+($G(DUZ)),"Code Set Date") S:'$L(DIRB) DIRB=LEXNOW S:$L($G(LEXAD)) DIRB=""
  1. S:$L(DIRB) DIR("B")=DIRB S DIR("A")=" Enter Code Set Update Date: "
  1. S DIR(0)="DAO^"_LEXPAS_":"_LEXFUT_":EX",(DIR("?"),DIR("??"))="^D CSDH^LEXQM",DIR("PRE")="S X=$$CSDX^LEXQM(X)"
  1. W ! D ^DIR S:X["^^"!($D(DTOUT)) X="^^",LEXEXIT=1 Q:X["^^"!(+($G(LEXEXIT))>0) "^^" Q:X["^" "^"
  1. S X="" S:$E(Y,1,7)?7N X=$$UP^XLFSTR($$FMTE^XLFDT($E(Y,1,7)))_"^"_$E(Y,1,7)
  1. D:$L($P(X,"^",1)) SAV^LEXQD("LEXQM","CSD",+($G(DUZ)),"Code Set Date",$P(X,"^",1))
  1. Q X
  1. CSDH ; Code Set Date Help
  1. W !,?3,"This is a date to used to search for Code Set changes in the ICD and CPT"
  1. W !,?3,"files. A future date may be used to search for changes in the Code Sets"
  1. W !,?3,"with future effective dates. (HINT: Most Code Set effective dates are"
  1. W !,?3,"quarterly, the first of January, April, July or October)"
  1. I $L($G(LEXFUT)),$G(LEXFUT)?7N D
  1. . W !!,?5,"Enter a date from ",$$UP^XLFSTR($$FMTE^XLFDT(LEXPAS))," to ",$$UP^XLFSTR($$FMTE^XLFDT(LEXFUT))," or"
  1. . W !,?5,"T (for TODAY), T+1 (for TOMORROW), T+2, T+7, etc."
  1. . W !,?5,"T-1 (for YESTERDAY), T-3W (for 3 WEEKS AGO), etc."
  1. . W !,?5,"Q1 (for first quarter), Q109 (for first quarter of FY09), etc."
  1. Q
  1. CSDX(X) ; Code Set Date Pre-Processing
  1. 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
  1. Q:X="Q2" (LEXY_"0101") Q:X="Q3" (LEXY_"0401") Q:X="Q4" (LEXY_"0701") Q:X="Q1" ((LEXY-1)_"1001")
  1. S LEXX="" I $E(X,1)="Q",$E(X,2,4)?3N D
  1. . 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
  1. . S LEXQ=$S(+LEXQ=1:"1001",+LEXQ=2:"0101",+LEXQ=3:"0401",+LEXQ=4:"0701",1:"") Q:'$L(LEXQ)
  1. . S:LEXF?4N&(LEXF>1976)&(LEXF<(+($G(LEXT))+3))&(LEXQ?4N) LEXX=(LEXF-1700)_LEXQ
  1. S:$L(LEXX) X=LEXX
  1. Q X
  1. TM(X,Y) ; Trim Character Y - Default " "
  1. 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))
  1. F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
  1. Q X
  1. ;
  1. ; Miscellaneous
  1. ATTR ; Screen Attributes
  1. N X S X="IOINHI;IOINORM" D ENDR^%ZISS S BOLD=$G(IOINHI),NORM=$G(IOINORM)
  1. Q
  1. KATTR ; Kill Screen Attributes
  1. D KILL^%ZISS K IOINHI,IOINORM,BOLD,NORM
  1. Q
  1. AND(X) ; Substitute 'and'
  1. S X=$G(X) Q:$L(X,", ")'>1 X
  1. S X=$P(X,", ",1,($L(X,", ")-1))_" and "_$P(X,", ",$L(X,", "))
  1. Q X
  1. CS(X) ; Trim Comma/Space
  1. S X=$$TM($G(X),","),X=$$TM($G(X)," "),X=$$TM($G(X),","),X=$$TM($G(X)," ")
  1. Q X
  1. SD(X) ; Short Date
  1. Q $TR($$FMTE^XLFDT(+($G(X)),"5DZ"),"@"," ")
  1. ED(X) ; External Date
  1. Q:+($G(X))'>0 "--/--/----"
  1. Q $TR($$FMTE^XLFDT(+($G(X)),"5DZ"),"@"," ")
  1. ES(X) ; External Status
  1. Q $S(+($G(X))="1":"Active",$G(X)="0":"Inactive",1:"")
  1. CLR ; Clear
  1. N LEXAD,LEXEXIT
  1. Q
  1. EV(X) ; Check environment
  1. N LEX S DT=$$DT^XLFDT D HOME^%ZIS S U="^" I +($G(DUZ))=0 W !!,?5,"DUZ not defined" Q 0
  1. S LEX=$$GET1^DIQ(200,(DUZ_","),.01) I '$L(LEX) W !!,?5,"DUZ not valid" Q 0
  1. Q 1