- LRCAP64S ;VA/DALIT/FHS - SEARCH 64 FOR CODES; 17-Oct-2014 09:22 ; MKK
- ;;5.2;LAB SERVICE;**258,369,1030,1034**;NOV 01, 1997;Build 88
- ;
- 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"
- S DIR(0)="SO^1:CPT;2:SNOMED;3:ICD;4:LOINC" ; IHS/MSC/MKK - LR*5.2*1034
- 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")
- S LRANS=$S(Y=1:" CPT",Y=2:" SNOMED,",Y=3:" ICD",1:" LOINC") ; IHS/MSC/MKK - LR*5.2*1034
- 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
- LRCAP64S ;VA/DALIT/FHS - SEARCH 64 FOR CODES; 17-Oct-2014 09:22 ; MKK
- +1 ;;5.2;LAB SERVICE;**258,369,1030,1034**;NOV 01, 1997;Build 88
- +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 ; S DIR(0)="SO^1:CPT;2:SNOMED;3:ICD9;4:LOINC"
- +7 ; IHS/MSC/MKK - LR*5.2*1034
- SET DIR(0)="SO^1:CPT;2:SNOMED;3:ICD;4:LOINC"
- +8 DO ^DIR
- +9 IF $GET(Y)<1
- GOTO END
- +10 SET LRAN=Y
- SET LRAN(0)=Y(0)
- +11 KILL LRCODE
- SET LRCODE=""
- +12 ; S LRANS=$S(Y=1:" CPT",Y=2:" SNOMED,",Y=3:" ICD9",1:" LOINC")
- +13 ; IHS/MSC/MKK - LR*5.2*1034
- SET LRANS=$SELECT(Y=1:" CPT",Y=2:" SNOMED,",Y=3:" ICD",1:" LOINC")
- +14 KILL DIR
- SET DIR("A")="Select "_Y(0)_" Code"
- +15 SET LRGLB=$SELECT(Y=1:";ICPT(",Y=2:";LAB(61.1,",Y=3:";ICD9(",1:"")
- +16 SET DIR(0)="PO^"_$SELECT(Y=1:"81",Y=2:"61.1",Y=3:"80",1:"95.3")_":ENMZQ"
- +17 FOR
- DO ^DIR
- IF Y<1
- QUIT
- Begin DoDot:1
- +18 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 "
- +19 IF LRAN=4
- SET LRCODE(+Y_"-"_LRANS)=" ["_$GET(^LAB(95.3,+Y,80))_"]"
- End DoDot:1
- +20 IF $DATA(DTOUT)!($DATA(DUOUT))
- GOTO END
- +21 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
