LEXQIPA ;ISL/KER - Query - ICD Procedure - Ask ;10/10/2017
;;2.0;LEXICON UTILITY;**62,80,103,114**;Sep 23, 1996;Build 1
;
; Global Variables
; None
;
; External References
; ^DIC ICR 10006
; $$CSI^ICDEX ICR 5747
; $$ICDOP^ICDEX ICR 5747
; $$ROOT^ICDEX ICR 5747
; $$DT^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed in LEXQIP
; LEXCDT,LEXEXIT
;
Q
ICP(X) ; ICD PR Code
Q:+($G(LEXEXIT))>0 "^^" N DIC,DICB,DTOUT,DUOUT,LEXDX,LEXSO,LEXDTXT,LEXVTXT,LEXVDT,Y,ICDVDT,ICDSYS,ICDFMT
S DICB=$G(X),ICDFMT=2 S:$P($G(LEXCDT),"^",2)?7N (LEXVDT,ICDVDT)=$P($G(LEXCDT),"^",2)
S:'$L($G(LEXVDT))&($P($G(LEXCDT),"^",1)?7N) (LEXVDT,ICDVDT)=$P($G(LEXCDT),"^",1)
S DIC(0)="AEQMZ",DIC=$$ROOT^ICDEX(80.1) S:$D(LEXQUIET) DIC(0)="MZ" I $L(DIC) D
. N ICDVDT,VDT S VDT=$O(^LEX(757.02,"AUPD","10P"," "),-1)
. S:VDT?7N VDT=$$FMADD^XLFDT(VDT,740) S:VDT?7N ICDVDT=VDT
. S DIC("A")=" Select an ICD Procedure code: " S:$L($G(DICB)) DIC("B")=$G(DICB) W ! D ^DIC
S X=$G(X),Y=$G(Y) 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
. N LEXSYS S LEXSYS=$$CSI^ICDEX(80.1,+Y),LEXVDT=$G(LEXCDT) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT S X=Y,LEXDTXT=$P($G(Y(0)),"^",2)
. S LEXDX=$$ICDOP^ICDEX(LEXSO,LEXVDT,LEXSYS,"E") S:$L($G(LEXDTXT)) LEXDTXT=LEXDTXT_" (Text not Versioned)"
. S LEXVTXT=$P(LEXDX,"^",5) 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQIPA 1749 printed Apr 09, 2024@21:11:43 Page 2
LEXQIPA ;ISL/KER - Query - ICD Procedure - Ask ;10/10/2017
+1 ;;2.0;LEXICON UTILITY;**62,80,103,114**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; None
+5 ;
+6 ; External References
+7 ; ^DIC ICR 10006
+8 ; $$CSI^ICDEX ICR 5747
+9 ; $$ICDOP^ICDEX ICR 5747
+10 ; $$ROOT^ICDEX ICR 5747
+11 ; $$DT^XLFDT ICR 10103
+12 ; $$UP^XLFSTR ICR 10104
+13 ;
+14 ; Local Variables NEWed or KILLed in LEXQIP
+15 ; LEXCDT,LEXEXIT
+16 ;
+17 QUIT
ICP(X) ; ICD PR Code
+1 if +($GET(LEXEXIT))>0
QUIT "^^"
NEW DIC,DICB,DTOUT,DUOUT,LEXDX,LEXSO,LEXDTXT,LEXVTXT,LEXVDT,Y,ICDVDT,ICDSYS,ICDFMT
+2 SET DICB=$GET(X)
SET ICDFMT=2
if $PIECE($GET(LEXCDT),"^",2)?7N
SET (LEXVDT,ICDVDT)=$PIECE($GET(LEXCDT),"^",2)
+3 if '$LENGTH($GET(LEXVDT))&($PIECE($GET(LEXCDT),"^",1)?7N)
SET (LEXVDT,ICDVDT)=$PIECE($GET(LEXCDT),"^",1)
+4 SET DIC(0)="AEQMZ"
SET DIC=$$ROOT^ICDEX(80.1)
if $DATA(LEXQUIET)
SET DIC(0)="MZ"
IF $LENGTH(DIC)
Begin DoDot:1
+5 NEW ICDVDT,VDT
SET VDT=$ORDER(^LEX(757.02,"AUPD","10P"," "),-1)
+6 if VDT?7N
SET VDT=$$FMADD^XLFDT(VDT,740)
if VDT?7N
SET ICDVDT=VDT
+7 SET DIC("A")=" Select an ICD Procedure code: "
if $LENGTH($GET(DICB))
SET DIC("B")=$GET(DICB)
WRITE !
DO ^DIC
End DoDot:1
+8 SET X=$GET(X)
SET Y=$GET(Y)
if $GET(X)["^^"!($DATA(DTOUT))
SET LEXEXIT=1
if $GET(X)["^^"!(+($GET(LEXEXIT))>0)
QUIT "^^"
+9 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
+10 NEW LEXSYS
SET LEXSYS=$$CSI^ICDEX(80.1,+Y)
SET LEXVDT=$GET(LEXCDT)
if LEXVDT'?7N
SET LEXVDT=$$DT^XLFDT
SET X=Y
SET LEXDTXT=$PIECE($GET(Y(0)),"^",2)
+11 SET LEXDX=$$ICDOP^ICDEX(LEXSO,LEXVDT,LEXSYS,"E")
if $LENGTH($GET(LEXDTXT))
SET LEXDTXT=LEXDTXT_" (Text not Versioned)"
+12 SET LEXVTXT=$PIECE(LEXDX,"^",5)
if '$LENGTH(LEXVTXT)
SET LEXVTXT=LEXDTXT
+13 SET X=+Y_"^"_LEXSO
if $LENGTH(LEXVTXT)
SET X=X_"^"_LEXVTXT
End DoDot:1
+14 SET X=$$UP^XLFSTR(X)
if '$LENGTH(X)
QUIT "^"
+15 QUIT X
