source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRTSTJM1.m@ 1604

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

initial load of WorldVistAEHR

File size: 1.3 KB
Line 
1LRTSTJM1 ;SLC/RJS- JAM TESTS ONTO (OR OFF) ACCESSIONS (cont.) ;10/10/91 14:00;
2 ;;5.2;LAB SERVICE;;Sep 27, 1994
3 ;
4EXPLD ;
5 S LRTSAD1=0 F S LRTSAD1=$O(LRTSAD(LRTSUB,LRTSAD1)) Q:'LRTSAD1 D EXPLD1
6 K LRTSAD1,LRTSAD2,LRTSAD3,LRTSAD4
7 Q
8EXPLD1 ;
9 Q:'$O(^LAB(60,LRTSAD1,2,0)) S LRTSAD4=LRTSAD1 N LRTSAD1,LRTSAD2,LRTSAD3 S LRTSAD2=LRTSAD4,LRTSAD3=0 K LRTSAD4
10 F S LRTSAD3=$O(^LAB(60,LRTSAD2,2,LRTSAD3)) Q:'LRTSAD3 I $D(^(LRTSAD3,0)),'$D(LRTSAD(LRTSUB,+^(0))) S LRTSAD1=+^(0),LRTSAD(LRTSUB,LRTSAD1)="" D EXPLD1
11 Q
12COMPTST ;
13 D SCAN K:LRTSUB LRTSAD(2) Q:LRTSUB
14 I '$L(LRTSURG) D COMTST2 S LRTSURG=LRURG I 'LRURG S LRTSUB=0 Q
15 S (LRTSAD,LRTS)=0 F S LRTS=$O(LRTSAD(2,LRTS)) Q:'LRTS I '$D(LRTSAD(1,LRTS)) D COMTST1
16 W:'LRTSAD !,"All the individual tests for this panel",!,"are already included on this accession."
17 K LRTSAD(2),LRTSURG
18 Q
19COMTST1 ;
20 Q:$O(^LAB(60,LRTS,2,0))
21 S LRTSAD=1,(Y,LRURG)=$S($L(LRTSURG):LRTSURG,1:$P(^LAB(60,LRTS,0),U,18)) W:'$L(Y) !,$P(^LAB(60,LRTS,0),U,1)
22 D COMTST2:'$L(Y) S LRFLG=1 G:LRURG SETTST^LRTSTJAM
23 Q
24COMTST2 ;
25 S DIC=62.05,DIC("B")="ROUTINE",DIC(0)="AEMOQ" D ^DIC K DIC("B") I Y<1 W !,"URGENCY must be defined. Test not added." S LRURG=0 Q
26 W !," ...OK" S %=1 D YN^DICN G COMTST2:%=2 S LRURG=$S((%<1):0,1:+Y)
27 Q
28SCAN ;
29 N LRTS S LRTS=0 F S LRTS=$O(LRTSAD(2,LRTS)) Q:'LRTS I $D(LRTSAD(1,LRTS)) S LRTSUB=0
30 Q
Note: See TracBrowser for help on using the repository browser.