LEXQCPA ;ISL/KER - Query - CPT Procedures - Ask ;04/21/2014
;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 10
;
; Global Variables
; None
;
; External References
; ^DIC ICR 10006
; ^DIR ICR 10026
; $$CPT^ICPTCOD ICR 1995
; $$DT^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed Elsewhere
; LEXCDT Code Set Date
; LEXEXIT Exit Flag
; LEXCPT CPT Code IEN^Text
;
Q
CPT(X) ; CPT Code
Q:+($G(LEXEXIT))>0 "^^" N DIC,DTOUT,DUOUT,LEXCP,LEXSO,LEXDTXT,LEXVTXT,LEXVDT,Y,ICPTVDT S:$G(LEXCDT)?7N ICPTVDT=$G(LEXCDT)
S DIC(0)="AEQMZ",DIC="^ICPT(",DIC("A")=" Select a CPT/HCPCS Procedure code: " W !
D ^DIC S:$G(X)["^^"!($D(DTOUT)) LEXEXIT=1 Q:$G(X)["^^"!(+($G(LEXEXIT))>0) "^^"
Q:$G(X)="^" "^" Q:$G(X)["^^" "^^" Q:$D(DTOUT)!($D(DUOUT)) "^" S LEXSO=$P($G(Y),"^",2) S X="" I +Y>0,$L(LEXSO) D
. S LEXVDT=$G(LEXCDT) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT S X=Y,LEXDTXT=$P($G(Y(0)),"^",2),LEXCP=$$CPT^ICPTCOD(LEXSO,LEXVDT)
. S:$L($G(LEXDTXT)) LEXDTXT=LEXDTXT_" (Text not Versioned)" S LEXVTXT=$P(LEXCP,"^",3) S:'$L(LEXVTXT) LEXVTXT=LEXDTXT
. S X=+Y_"^"_LEXSO S:$L(LEXVTXT) X=X_"^"_LEXVTXT
S X=$$UP^XLFSTR(X) Q:'$L(X) "^"
Q X
INC(X) ; Include CPT Modifiers
Q:+($G(LEXEXIT))>0 "^^" N DIR,DIRUT,DIROUT,DTOUT,DUOUT,Y,DIRB S DIRB=$$RET^LEXQD("LEXQCPA","INC",+($G(DUZ)),"Include Modifiers") S:'$L(DIRB) DIRB="Yes"
S DIR(0)="YAO",DIR("A")=" Include CPT Modifiers? (Y/N) " S:"^YES^NO^Yes^No^"[("^"_DIRB_"^") DIR("B")=DIRB
S DIR("PRE")="S:X[""?"" X=""??""" S (DIR("?"),DIR("??"))="^D INCH^LEXQCPA"
W ! D ^DIR S:X["^^"!($D(DTOUT)) LEXEXIT=1 Q:X["^^"!(+($G(LEXEXIT))>0) "^^" Q:$D(DIRUT)!($D(DIROUT))!($D(DTOUT))!($D(DUOUT)) "^" S DIRB=$S(Y=1:"Yes",Y=0:"No",X["^":"",1:"")
D:$L(DIRB) SAV^LEXQD("LEXQCPA","INC",+($G(DUZ)),"Include Modifiers",$G(DIRB)) S X=+Y
Q X
INCH ; Include Help
I $L($P($G(LEXCPT),"^",2)),$G(LEXCDT)?7N D Q
. W !,?5,"Answer 'Yes' to include active CPT Modifiers that are appropriate for"
. W !,?5,"CPT code ",$P($G(LEXCPT),"^",2)," on ",$$SD($G(LEXCDT))
W !,?5,"Answer 'Yes' to include active CPT Modifiers that are appropriate"
W !,?5,"for the CPT code, 'No' to exclude CPT Modifiers from the display"
Q
SD(X) ; Short Date
Q $TR($$FMTE^XLFDT(+($G(X)),"5DZ"),"@"," ")
CLR ; Clear
N LEXCDT,LEXCPT,LEXEXIT
Q
LEXQCPA ;ISL/KER - Query - CPT Procedures - Ask ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; None
+5 ;
+6 ; External References
+7 ; ^DIC ICR 10006
+8 ; ^DIR ICR 10026
+9 ; $$CPT^ICPTCOD ICR 1995
+10 ; $$DT^XLFDT ICR 10103
+11 ; $$FMTE^XLFDT ICR 10103
+12 ; $$UP^XLFSTR ICR 10104
+13 ;
+14 ; Local Variables NEWed or KILLed Elsewhere
+15 ; LEXCDT Code Set Date
+16 ; LEXEXIT Exit Flag
+17 ; LEXCPT CPT Code IEN^Text
+18 ;
+19 QUIT
CPT(X) ; CPT Code
+1 IF +($GET(LEXEXIT))>0
QUIT "^^"
NEW DIC,DTOUT,DUOUT,LEXCP,LEXSO,LEXDTXT,LEXVTXT,LEXVDT,Y,ICPTVDT
IF $GET(LEXCDT)?7N
SET ICPTVDT=$GET(LEXCDT)
+2 SET DIC(0)="AEQMZ"
SET DIC="^ICPT("
SET DIC("A")=" Select a CPT/HCPCS Procedure code: "
WRITE !
+3 DO ^DIC
IF $GET(X)["^^"!($DATA(DTOUT))
SET LEXEXIT=1
IF $GET(X)["^^"!(+($GET(LEXEXIT))>0)
QUIT "^^"
+4 IF $GET(X)="^"
QUIT "^"
IF $GET(X)["^^"
QUIT "^^"
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT "^"
SET LEXSO=$PIECE($GET(Y),"^",2)
SET X=""
IF +Y>0
IF $LENGTH(LEXSO)
Begin DoDot:1
+5 SET LEXVDT=$GET(LEXCDT)
IF LEXVDT'?7N
SET LEXVDT=$$DT^XLFDT
SET X=Y
SET LEXDTXT=$PIECE($GET(Y(0)),"^",2)
SET LEXCP=$$CPT^ICPTCOD(LEXSO,LEXVDT)
+6 IF $LENGTH($GET(LEXDTXT))
SET LEXDTXT=LEXDTXT_" (Text not Versioned)"
SET LEXVTXT=$PIECE(LEXCP,"^",3)
IF '$LENGTH(LEXVTXT)
SET LEXVTXT=LEXDTXT
+7 SET X=+Y_"^"_LEXSO
IF $LENGTH(LEXVTXT)
SET X=X_"^"_LEXVTXT
End DoDot:1
+8 SET X=$$UP^XLFSTR(X)
IF '$LENGTH(X)
QUIT "^"
+9 QUIT X
INC(X) ; Include CPT Modifiers
+1 IF +($GET(LEXEXIT))>0
QUIT "^^"
NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT,Y,DIRB
SET DIRB=$$RET^LEXQD("LEXQCPA","INC",+($GET(DUZ)),"Include Modifiers")
IF '$LENGTH(DIRB)
SET DIRB="Yes"
+2 SET DIR(0)="YAO"
SET DIR("A")=" Include CPT Modifiers? (Y/N) "
IF "^YES^NO^Yes^No^"[("^"_DIRB_"^")
SET DIR("B")=DIRB
+3 SET DIR("PRE")="S:X[""?"" X=""??"""
SET (DIR("?"),DIR("??"))="^D INCH^LEXQCPA"
+4 WRITE !
DO ^DIR
IF X["^^"!($DATA(DTOUT))
SET LEXEXIT=1
IF X["^^"!(+($GET(LEXEXIT))>0)
QUIT "^^"
IF $DATA(DIRUT)!($DATA(DIROUT))!($DATA(DTOUT))!($DATA(DUOUT))
QUIT "^"
SET DIRB=$SELECT(Y=1:"Yes",Y=0:"No",X["^":"",1:"")
+5 IF $LENGTH(DIRB)
DO SAV^LEXQD("LEXQCPA","INC",+($GET(DUZ)),"Include Modifiers",$GET(DIRB))
SET X=+Y
+6 QUIT X
INCH ; Include Help
+1 IF $LENGTH($PIECE($GET(LEXCPT),"^",2))
IF $GET(LEXCDT)?7N
Begin DoDot:1
+2 WRITE !,?5,"Answer 'Yes' to include active CPT Modifiers that are appropriate for"
+3 WRITE !,?5,"CPT code ",$PIECE($GET(LEXCPT),"^",2)," on ",$$SD($GET(LEXCDT))
End DoDot:1
QUIT
+4 WRITE !,?5,"Answer 'Yes' to include active CPT Modifiers that are appropriate"
+5 WRITE !,?5,"for the CPT code, 'No' to exclude CPT Modifiers from the display"
+6 QUIT
SD(X) ; Short Date
+1 QUIT $TRANSLATE($$FMTE^XLFDT(+($GET(X)),"5DZ"),"@"," ")
CLR ; Clear
+1 NEW LEXCDT,LEXCPT,LEXEXIT
+2 QUIT
