source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LR7OB68.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.5 KB
Line 
1LR7OB68 ;slc/dcm - Get Lab data from 68 ;8/11/97
2 ;;5.2;LAB SERVICE;**121**;Sep 27, 1994
3 ;
468(CTR,ACCDT,ACC,ACCN,TEST) ;Get data from file 68
5 ;CTR=Counter
6 ;ACCDT=Accession Date subscript
7 ;ACC=Accession area subscript
8 ;ACCN=Accession # subscript
9 ;TEST=test ptr
10 ;See ^LR7OB69 for description of LRX array
11 N X0,XP1,XP2,X3,IFN,Y1,Y2,Y3,Y4,Y5,Y6,Y7 K ^TMP("LRX",$J,68)
12 Q:'$D(^LRO(68,+ACC,1,+ACCDT,1,+ACCN,0)) S X0=^(0),XP1=$G(^(.1)),XP2=$G(^(.2)),X3=$G(^(3))
13 S Y1=+XP1,Y2=$P(X0,"^"),Y3=XP2,Y4=$P(X3,"^"),Y5=$P(X3,"^",3),Y6=$P(X3,"^",4),Y7=$P(X3,"^",5)
14 S ^TMP("LRX",$J,69,CTR,68)=Y1_"^"_Y2_"^"_Y3_"^"_Y4_"^"_Y5_"^"_Y6_"^"_Y7
15 I $D(^LRO(68,ACC,1,ACCDT,1,ACCN,4,TEST)) S X=^(TEST,0),^TMP("LRX",$J,69,CTR,68,TEST)=+X_"^"_$P(X,"^",2)_"^"_$P(X,"^",4)_"^"_$P(X,"^",5) D 63^LR7OB63(CTR,Y2,$P($G(^LRO(68,ACC,0)),"^",2),Y7,+$G(CORRECT))
16 Q
17A68(ACCDT,ACC,ACCN) ;Get data from file 68 when no 69 data exists
18 ;Used for accessions that have no corresponding entries in file 69
19 ;i.e. CY,EM,AU,SP (as of this version they all do)
20 ;ACCDT=Accession Date subscript
21 ;ACC=Accession area subscript
22 ;ACCN=Accession # subscript
23 N X0,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12,XP1,XP2,XAC,GOTCOM
24 Q:'$D(^LRO(68,+ACC,1,+ACCDT,1,+ACCN,0)) S X0=^(0),XP1=$G(^(.1)),XP2=$G(^(.2)),X3=$G(^(3))
25 Q:'$D(^LR(+X0,0)) ;No matching entry in ^LR
26 S Y11=$S($P($G(^LRO(69,+$P(X0,"^",4),1,+$P(X0,"^",5),0)),"^",11):$P(^(0),"^",11),1:""),Y12=$P(X0,"^",10)
27 S:'$D(DFN) DFN=$P(^LR(+X0,0),"^",3) S:'$D(LRDFN) LRDFN=+X0 S:'$D(LRDPF) LRDPF=$P(^LR(+X0,0),"^",2)_$G(^DIC(+$P(^LR(+X0,0),"^",2),0,"GL"))
28 S Y1=+XP1,Y2=+X3,Y3="",Y4="",Y5=$P(X0,"^",4),Y6=$P(X0,"^",8),Y7=$P(X0,"^",7),Y8=$P(X3,"^",3),Y9=$P(X3,"^",4),Y10="",CTR=1
29 S ^TMP("LRX",$J,69)=Y1_"^"_Y2_"^"_Y3_"^"_Y4_"^"_Y5_"^"_Y6_"^"_Y7_"^"_Y8_"^"_Y9_"^"_Y10_"^"_Y11_"^"_Y12
30 S Y1=+XP1,Y2=$P(X0,"^"),Y3=XP2,Y4=$P(X3,"^"),Y5=$P(X3,"^",3),Y6=$P(X3,"^",4),Y7=$P(X3,"^",5)
31 S XAC=$P($G(^LRO(68,ACC,0)),"^",2),X=$S(XAC="CY":$O(^LAB(60,"B","CYTOPATHOLOGY",0)),XAC="EM":$O(^LAB(60,"B","ELECTRON MICROSCOPY",0)),XAC="AU":$O(^LAB(60,"B","AUTOPSY",0)),XAC="SP":$O(^LAB(60,"B","SURGICAL PATHOLOGY",0)),1:"")
32 I X="" S X=$S(XAC="CY":"CYTOPATHOLOGY",XAC="EM":"ELECTRON MICROSCOPY",XAC="AU":"AUTOPSY",XAC="SP":"SURGICAL PATHOLOGY",1:"")
33 S ^TMP("LRX",$J,69,CTR)=X_"^^"_ACCDT_"^"_ACC_"^"_ACCN
34 S ^TMP("LRX",$J,69,CTR,68)=Y1_"^"_Y2_"^"_Y3_"^"_Y4_"^"_Y5_"^"_Y6_"^"_Y7
35 S TEST=0 F S TEST=$O(^LRO(68,ACC,1,ACCDT,1,ACCN,4,TEST)) Q:TEST<1 S X=^(TEST,0),^TMP("LRX",$J,69,CTR,68,TEST)=+X_"^"_$P(X,"^",2)_"^"_$P(X,"^",4)_"^"_$P(X,"^",5) D 63^LR7OB63(CTR,Y2,XAC,Y7,+$G(CORRECT))
36 Q
Note: See TracBrowser for help on using the repository browser.