LRCAP64S ;DALISC/FHS - SEARCH 64 FOR CODES
;;5.2;LAB SERVICE;**258,369**;Sep 27, 1994;Build 2
EN ;
K DA,DIR,LRCPT,LRAN,LRANS,LRCODE,LRN,Y,X,LRX,LRIEN,%ZIS
K ^TMP("LROUT",$J)
S DIR("A")="Select the code type"
S DIR("?",1)="Indicate what code you want to find in the"
S DIR("?")="CODE field of the WKLD CODE file."
S DIR(0)="SO^1:CPT;2:SNOMED;3:ICD9;4:LOINC"
D ^DIR
G END:$G(Y)<1
S LRAN=Y,LRAN(0)=Y(0)
K LRCODE S LRCODE=""
S LRANS=$S(Y=1:" CPT",Y=2:" SNOMED,",Y=3:" ICD9",1:" LOINC")
K DIR S DIR("A")="Select "_Y(0)_" Code"
S LRGLB=$S(Y=1:";ICPT(",Y=2:";LAB(61.1,",Y=3:";ICD9(",1:"")
S DIR(0)="PO^"_$S(Y=1:"81",Y=2:"61.1",Y=3:"80",1:"95.3")_":ENMZQ"
F D ^DIR Q:Y<1 D
. I LRAN'=4 S LRCODE(+Y_LRGLB_"-"_LRANS)=" ["_$S(LRAN=3:$P(Y(0),U,3),1:$P(Y(0),U,2))_"]",DIR("A")=" Select another "_LRAN(0)_" code "
. I LRAN=4 S LRCODE(+Y_"-"_LRANS)=" ["_$G(^LAB(95.3,+Y,80))_"]"
G:$D(DTOUT)!($D(DUOUT)) END
I $O(LRCODE(0))="" W !?5,"Nothing Selected ",!!,$C(7) G END
DEV ;SELECT DEVICE
K %ZIS S %ZIS="Q" D ^%ZIS G:POP!($D(DUOUT))!($D(DTOUT)) END
I $D(IO("Q")) G QUE
U IO
DEQUE ;
S LREND=0 W:$E(IOST,1,2)="C-" @IOF
I $D(ZTDEQUED) S ZTREQ="@"
S LRHD=LRANS_" Listing "_$$FMTE^XLFDT($$NOW^XLFDT,"1P")
S LRPG=0 D HD
S LRN="" F S LRN=$O(LRCODE(LRN)) Q:LRN=""!($G(LREND)) D
. K ^TMP("LROUT",$J) D FIND^DIC(64,"","@;.01;1;IX",$S(LRAN=4:"XQ",1:"QM"),$P(LRN,"-"),"",$S(LRAN=4:"AH^AI",1:"AB"),"","","^TMP(""LROUT"",$J)")
. I '$O(^TMP("LROUT",$J,"DILIST",0)) D Q
. . D TOP Q:$G(LREND)
. . W !!?2,$TR(LRN,";(-"," ")_$P(LRCODE(LRN),U),!?5," [ IS NOT LINKED ]"
. I $O(^TMP("LROUT",$J,"DILIST",0)) D
. . D TOP Q:$G(LREND)
. . W !!?2,$TR(LRN,";("," ")_$P(LRCODE(LRN),U)_" linked to:"
. . S LRX=0 F S LRX=$O(^TMP("LROUT",$J,"DILIST",2,LRX)) Q:LRX<1 Q:LREND D
. . . S LRIEN=^TMP("LROUT",$J,"DILIST",2,LRX)
. . . S LRANOUT=^TMP("LROUT",$J,"DILIST","ID",LRX,1)_" "_^TMP("LROUT",$J,"DILIST","ID",LRX,.01)
. . . D TOP Q:$G(LREND) W !?4,LRIEN,?15,$E(LRANOUT,1,64)
G:$D(DTOUT)!($D(DUOUT)) END
W !?10,"Finished"
END ;
W ! I $E(IOST,1,2)="P-" W @IOF
D ^%ZISC
Q:$G(LRDEBUG)
K DA,DIR,DIRUT,DTOUT,DUOUT,LRAN,LRANOUT,LRANS,LRCODE,LRCPT,LREND
K LRGLB,LRHD,LRIEN,LRN,LRPG,LRX,POP,X,Y
K ZTDEQUED,ZTREQ,ZTSK,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSTOP
K ^TMP("LROUT",$J) D CLEAN^DILF
Q
TOP ;
I $$S^%ZTLOAD("Report Stopped") S (ZTSTOP,LREND)=1 Q
N DIR
Q:$Y<(IOSL-4)
I $E(IOST,1,2)="P-" G HD
N DIR
S DIR(0)="E" D ^DIR
S:$D(DTOUT)!($D(DUOUT)) LREND=1
I $G(LREND) W !! Q
HD ;
S LRPG=$G(LRPG)+1
W:$G(LRN)'="" @IOF
W !!,$$CJ^XLFSTR(LRHD_" Page: "_LRPG,IOM)
I $G(LRN)'="" W !?2,$TR(LRN,";("," ")_$P(LRCODE(LRN),U)_" linked to:"
Q
QUE ;
K ZTDTH
S ZTRTN="DEQUE^LRCAP64S",ZTSAVE("LR*")=""
S ZTDESC="Lab List of codes from LAM"
S ZTIO=ION D ^%ZTLOAD
I $G(ZTSK) W !,$$CJ^XLFSTR("Queued to "_ION,80)
G END
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCAP64S 2892 printed Sep 23, 2025@19:48:11 Page 2
LRCAP64S ;DALISC/FHS - SEARCH 64 FOR CODES
+1 ;;5.2;LAB SERVICE;**258,369**;Sep 27, 1994;Build 2
EN ;
+1 KILL DA,DIR,LRCPT,LRAN,LRANS,LRCODE,LRN,Y,X,LRX,LRIEN,%ZIS
+2 KILL ^TMP("LROUT",$JOB)
+3 SET DIR("A")="Select the code type"
+4 SET DIR("?",1)="Indicate what code you want to find in the"
+5 SET DIR("?")="CODE field of the WKLD CODE file."
+6 SET DIR(0)="SO^1:CPT;2:SNOMED;3:ICD9;4:LOINC"
+7 DO ^DIR
+8 if $GET(Y)<1
GOTO END
+9 SET LRAN=Y
SET LRAN(0)=Y(0)
+10 KILL LRCODE
SET LRCODE=""
+11 SET LRANS=$SELECT(Y=1:" CPT",Y=2:" SNOMED,",Y=3:" ICD9",1:" LOINC")
+12 KILL DIR
SET DIR("A")="Select "_Y(0)_" Code"
+13 SET LRGLB=$SELECT(Y=1:";ICPT(",Y=2:";LAB(61.1,",Y=3:";ICD9(",1:"")
+14 SET DIR(0)="PO^"_$SELECT(Y=1:"81",Y=2:"61.1",Y=3:"80",1:"95.3")_":ENMZQ"
+15 FOR
DO ^DIR
if Y<1
QUIT
Begin DoDot:1
+16 IF LRAN'=4
SET LRCODE(+Y_LRGLB_"-"_LRANS)=" ["_$SELECT(LRAN=3:$PIECE(Y(0),U,3),1:$PIECE(Y(0),U,2))_"]"
SET DIR("A")=" Select another "_LRAN(0)_" code "
+17 IF LRAN=4
SET LRCODE(+Y_"-"_LRANS)=" ["_$GET(^LAB(95.3,+Y,80))_"]"
End DoDot:1
+18 if $DATA(DTOUT)!($DATA(DUOUT))
GOTO END
+19 IF $ORDER(LRCODE(0))=""
WRITE !?5,"Nothing Selected ",!!,$CHAR(7)
GOTO END
DEV ;SELECT DEVICE
+1 KILL %ZIS
SET %ZIS="Q"
DO ^%ZIS
if POP!($DATA(DUOUT))!($DATA(DTOUT))
GOTO END
+2 IF $DATA(IO("Q"))
GOTO QUE
+3 USE IO
DEQUE ;
+1 SET LREND=0
if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+2 IF $DATA(ZTDEQUED)
SET ZTREQ="@"
+3 SET LRHD=LRANS_" Listing "_$$FMTE^XLFDT($$NOW^XLFDT,"1P")
+4 SET LRPG=0
DO HD
+5 SET LRN=""
FOR
SET LRN=$ORDER(LRCODE(LRN))
if LRN=""!($GET(LREND))
QUIT
Begin DoDot:1
+6 KILL ^TMP("LROUT",$JOB)
DO FIND^DIC(64,"","@;.01;1;IX",$SELECT(LRAN=4:"XQ",1:"QM"),$PIECE(LRN,"-"),"",$SELECT(LRAN=4:"AH^AI",1:"AB"),"","","^TMP(""LROUT"",$J)")
+7 IF '$ORDER(^TMP("LROUT",$JOB,"DILIST",0))
Begin DoDot:2
+8 DO TOP
if $GET(LREND)
QUIT
+9 WRITE !!?2,$TRANSLATE(LRN,";(-"," ")_$PIECE(LRCODE(LRN),U),!?5," [ IS NOT LINKED ]"
End DoDot:2
QUIT
+10 IF $ORDER(^TMP("LROUT",$JOB,"DILIST",0))
Begin DoDot:2
+11 DO TOP
if $GET(LREND)
QUIT
+12 WRITE !!?2,$TRANSLATE(LRN,";("," ")_$PIECE(LRCODE(LRN),U)_" linked to:"
+13 SET LRX=0
FOR
SET LRX=$ORDER(^TMP("LROUT",$JOB,"DILIST",2,LRX))
if LRX<1
QUIT
if LREND
QUIT
Begin DoDot:3
+14 SET LRIEN=^TMP("LROUT",$JOB,"DILIST",2,LRX)
+15 SET LRANOUT=^TMP("LROUT",$JOB,"DILIST","ID",LRX,1)_" "_^TMP("LROUT",$JOB,"DILIST","ID",LRX,.01)
+16 DO TOP
if $GET(LREND)
QUIT
WRITE !?4,LRIEN,?15,$EXTRACT(LRANOUT,1,64)
End DoDot:3
End DoDot:2
End DoDot:1
+17 if $DATA(DTOUT)!($DATA(DUOUT))
GOTO END
+18 WRITE !?10,"Finished"
END ;
+1 WRITE !
IF $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
+2 DO ^%ZISC
+3 if $GET(LRDEBUG)
QUIT
+4 KILL DA,DIR,DIRUT,DTOUT,DUOUT,LRAN,LRANOUT,LRANS,LRCODE,LRCPT,LREND
+5 KILL LRGLB,LRHD,LRIEN,LRN,LRPG,LRX,POP,X,Y
+6 KILL ZTDEQUED,ZTREQ,ZTSK,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSTOP
+7 KILL ^TMP("LROUT",$JOB)
DO CLEAN^DILF
+8 QUIT
TOP ;
+1 IF $$S^%ZTLOAD("Report Stopped")
SET (ZTSTOP,LREND)=1
QUIT
+2 NEW DIR
+3 if $Y<(IOSL-4)
QUIT
+4 IF $EXTRACT(IOST,1,2)="P-"
GOTO HD
+5 NEW DIR
+6 SET DIR(0)="E"
DO ^DIR
+7 if $DATA(DTOUT)!($DATA(DUOUT))
SET LREND=1
+8 IF $GET(LREND)
WRITE !!
QUIT
HD ;
+1 SET LRPG=$GET(LRPG)+1
+2 if $GET(LRN)'=""
WRITE @IOF
+3 WRITE !!,$$CJ^XLFSTR(LRHD_" Page: "_LRPG,IOM)
+4 IF $GET(LRN)'=""
WRITE !?2,$TRANSLATE(LRN,";("," ")_$PIECE(LRCODE(LRN),U)_" linked to:"
+5 QUIT
QUE ;
+1 KILL ZTDTH
+2 SET ZTRTN="DEQUE^LRCAP64S"
SET ZTSAVE("LR*")=""
+3 SET ZTDESC="Lab List of codes from LAM"
+4 SET ZTIO=ION
DO ^%ZTLOAD
+5 IF $GET(ZTSK)
WRITE !,$$CJ^XLFSTR("Queued to "_ION,80)
+6 GOTO END
+7 QUIT
