source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRCAP64S.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.7 KB
Line 
1LRCAP64S ;DALISC/FHS - SEARCH 64 FOR CODES
2 ;;5.2;LAB SERVICE;**258,369**;Sep 27, 1994;Build 2
3EN ;
4 K DA,DIR,LRCPT,LRAN,LRANS,LRCODE,LRN,Y,X,LRX,LRIEN,%ZIS
5 K ^TMP("LROUT",$J)
6 S DIR("A")="Select the code type"
7 S DIR("?",1)="Indicate what code you want to find in the"
8 S DIR("?")="CODE field of the WKLD CODE file."
9 S DIR(0)="SO^1:CPT;2:SNOMED;3:ICD9;4:LOINC"
10 D ^DIR
11 G END:$G(Y)<1
12 S LRAN=Y,LRAN(0)=Y(0)
13 K LRCODE S LRCODE=""
14 S LRANS=$S(Y=1:" CPT",Y=2:" SNOMED,",Y=3:" ICD9",1:" LOINC")
15 K DIR S DIR("A")="Select "_Y(0)_" Code"
16 S LRGLB=$S(Y=1:";ICPT(",Y=2:";LAB(61.1,",Y=3:";ICD9(",1:"")
17 S DIR(0)="PO^"_$S(Y=1:"81",Y=2:"61.1",Y=3:"80",1:"95.3")_":ENMZQ"
18 F D ^DIR Q:Y<1 D
19 . 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 "
20 . I LRAN=4 S LRCODE(+Y_"-"_LRANS)=" ["_$G(^LAB(95.3,+Y,80))_"]"
21 G:$D(DTOUT)!($D(DUOUT)) END
22 I $O(LRCODE(0))="" W !?5,"Nothing Selected ",!!,$C(7) G END
23DEV ;SELECT DEVICE
24 K %ZIS S %ZIS="Q" D ^%ZIS G:POP!($D(DUOUT))!($D(DTOUT)) END
25 I $D(IO("Q")) G QUE
26 U IO
27DEQUE ;
28 S LREND=0 W:$E(IOST,1,2)="C-" @IOF
29 I $D(ZTDEQUED) S ZTREQ="@"
30 S LRHD=LRANS_" Listing "_$$FMTE^XLFDT($$NOW^XLFDT,"1P")
31 S LRPG=0 D HD
32 S LRN="" F S LRN=$O(LRCODE(LRN)) Q:LRN=""!($G(LREND)) D
33 . 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)")
34 . I '$O(^TMP("LROUT",$J,"DILIST",0)) D Q
35 . . D TOP Q:$G(LREND)
36 . . W !!?2,$TR(LRN,";(-"," ")_$P(LRCODE(LRN),U),!?5," [ IS NOT LINKED ]"
37 . I $O(^TMP("LROUT",$J,"DILIST",0)) D
38 . . D TOP Q:$G(LREND)
39 . . W !!?2,$TR(LRN,";("," ")_$P(LRCODE(LRN),U)_" linked to:"
40 . . S LRX=0 F S LRX=$O(^TMP("LROUT",$J,"DILIST",2,LRX)) Q:LRX<1 Q:LREND D
41 . . . S LRIEN=^TMP("LROUT",$J,"DILIST",2,LRX)
42 . . . S LRANOUT=^TMP("LROUT",$J,"DILIST","ID",LRX,1)_" "_^TMP("LROUT",$J,"DILIST","ID",LRX,.01)
43 . . . D TOP Q:$G(LREND) W !?4,LRIEN,?15,$E(LRANOUT,1,64)
44 G:$D(DTOUT)!($D(DUOUT)) END
45 W !?10,"Finished"
46END ;
47 W ! I $E(IOST,1,2)="P-" W @IOF
48 D ^%ZISC
49 Q:$G(LRDEBUG)
50 K DA,DIR,DIRUT,DTOUT,DUOUT,LRAN,LRANOUT,LRANS,LRCODE,LRCPT,LREND
51 K LRGLB,LRHD,LRIEN,LRN,LRPG,LRX,POP,X,Y
52 K ZTDEQUED,ZTREQ,ZTSK,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSTOP
53 K ^TMP("LROUT",$J) D CLEAN^DILF
54 Q
55TOP ;
56 I $$S^%ZTLOAD("Report Stopped") S (ZTSTOP,LREND)=1 Q
57 N DIR
58 Q:$Y<(IOSL-4)
59 I $E(IOST,1,2)="P-" G HD
60 N DIR
61 S DIR(0)="E" D ^DIR
62 S:$D(DTOUT)!($D(DUOUT)) LREND=1
63 I $G(LREND) W !! Q
64HD ;
65 S LRPG=$G(LRPG)+1
66 W:$G(LRN)'="" @IOF
67 W !!,$$CJ^XLFSTR(LRHD_" Page: "_LRPG,IOM)
68 I $G(LRN)'="" W !?2,$TR(LRN,";("," ")_$P(LRCODE(LRN),U)_" linked to:"
69 Q
70QUE ;
71 K ZTDTH
72 S ZTRTN="DEQUE^LRCAP64S",ZTSAVE("LR*")=""
73 S ZTDESC="Lab List of codes from LAM"
74 S ZTIO=ION D ^%ZTLOAD
75 I $G(ZTSK) W !,$$CJ^XLFSTR("Queued to "_ION,80)
76 G END
77 Q
Note: See TracBrowser for help on using the repository browser.