LR7OB68 ; IHS/DIR/AAB - Get Lab data from 68 ; [ 8/11/97 ]
;;5.2;LR;**1003**;JUN 01, 1998
;
;;5.2;LAB SERVICE;**121**;Sep 27, 1994
;
68(CTR,ACCDT,ACC,ACCN,TEST) ;Get data from file 68
;CTR=Counter
;ACCDT=Accession Date subscript
;ACC=Accession area subscript
;ACCN=Accession # subscript
;TEST=test ptr
;See ^LR7OB69 for description of LRX array
N X0,XP1,XP2,X3,IFN,Y1,Y2,Y3,Y4,Y5,Y6,Y7 K ^TMP("LRX",$J,68)
Q:'$D(^LRO(68,+ACC,1,+ACCDT,1,+ACCN,0)) S X0=^(0),XP1=$G(^(.1)),XP2=$G(^(.2)),X3=$G(^(3))
S Y1=+XP1,Y2=$P(X0,"^"),Y3=XP2,Y4=$P(X3,"^"),Y5=$P(X3,"^",3),Y6=$P(X3,"^",4),Y7=$P(X3,"^",5)
S ^TMP("LRX",$J,69,CTR,68)=Y1_"^"_Y2_"^"_Y3_"^"_Y4_"^"_Y5_"^"_Y6_"^"_Y7
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))
Q
A68(ACCDT,ACC,ACCN) ;Get data from file 68 when no 69 data exists
;Used for accessions that have no corresponding entries in file 69
;i.e. CY,EM,AU,SP (as of this version they all do)
;ACCDT=Accession Date subscript
;ACC=Accession area subscript
;ACCN=Accession # subscript
N X0,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12,XP1,XP2,XAC,GOTCOM
Q:'$D(^LRO(68,+ACC,1,+ACCDT,1,+ACCN,0)) S X0=^(0),XP1=$G(^(.1)),XP2=$G(^(.2)),X3=$G(^(3))
Q:'$D(^LR(+X0,0)) ;No matching entry in ^LR
S Y11=$S($P($G(^LRO(69,+$P(X0,"^",4),1,+$P(X0,"^",5),0)),"^",11):$P(^(0),"^",11),1:""),Y12=$P(X0,"^",10)
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"))
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
S ^TMP("LRX",$J,69)=Y1_"^"_Y2_"^"_Y3_"^"_Y4_"^"_Y5_"^"_Y6_"^"_Y7_"^"_Y8_"^"_Y9_"^"_Y10_"^"_Y11_"^"_Y12
S Y1=+XP1,Y2=$P(X0,"^"),Y3=XP2,Y4=$P(X3,"^"),Y5=$P(X3,"^",3),Y6=$P(X3,"^",4),Y7=$P(X3,"^",5)
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:"")
I X="" S X=$S(XAC="CY":"CYTOPATHOLOGY",XAC="EM":"ELECTRON MICROSCOPY",XAC="AU":"AUTOPSY",XAC="SP":"SURGICAL PATHOLOGY",1:"")
S ^TMP("LRX",$J,69,CTR)=X_"^^"_ACCDT_"^"_ACC_"^"_ACCN
S ^TMP("LRX",$J,69,CTR,68)=Y1_"^"_Y2_"^"_Y3_"^"_Y4_"^"_Y5_"^"_Y6_"^"_Y7
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))
Q
LR7OB68 ; IHS/DIR/AAB - Get Lab data from 68 ; [ 8/11/97 ]
+1 ;;5.2;LR;**1003**;JUN 01, 1998
+2 ;
+3 ;;5.2;LAB SERVICE;**121**;Sep 27, 1994
+4 ;
68(CTR,ACCDT,ACC,ACCN,TEST) ;Get data from file 68
+1 ;CTR=Counter
+2 ;ACCDT=Accession Date subscript
+3 ;ACC=Accession area subscript
+4 ;ACCN=Accession # subscript
+5 ;TEST=test ptr
+6 ;See ^LR7OB69 for description of LRX array
+7 NEW X0,XP1,XP2,X3,IFN,Y1,Y2,Y3,Y4,Y5,Y6,Y7
KILL ^TMP("LRX",$JOB,68)
+8 IF '$DATA(^LRO(68,+ACC,1,+ACCDT,1,+ACCN,0))
QUIT
SET X0=^(0)
SET XP1=$GET(^(.1))
SET XP2=$GET(^(.2))
SET X3=$GET(^(3))
+9 SET Y1=+XP1
SET Y2=$PIECE(X0,"^")
SET Y3=XP2
SET Y4=$PIECE(X3,"^")
SET Y5=$PIECE(X3,"^",3)
SET Y6=$PIECE(X3,"^",4)
SET Y7=$PIECE(X3,"^",5)
+10 SET ^TMP("LRX",$JOB,69,CTR,68)=Y1_"^"_Y2_"^"_Y3_"^"_Y4_"^"_Y5_"^"_Y6_"^"_Y7
+11 IF $DATA(^LRO(68,ACC,1,ACCDT,1,ACCN,4,TEST))
SET X=^(TEST,0)
SET ^TMP("LRX",$JOB,69,CTR,68,TEST)=+X_"^"_$PIECE(X,"^",2)_"^"_$PIECE(X,"^",4)_"^"_$PIECE(X,"^",5)
DO 63^LR7OB63(CTR,Y2,$PIECE($GET(^LRO(68,ACC,0)),"^",2),Y7,+$GET(CORRECT))
+12 QUIT
A68(ACCDT,ACC,ACCN) ;Get data from file 68 when no 69 data exists
+1 ;Used for accessions that have no corresponding entries in file 69
+2 ;i.e. CY,EM,AU,SP (as of this version they all do)
+3 ;ACCDT=Accession Date subscript
+4 ;ACC=Accession area subscript
+5 ;ACCN=Accession # subscript
+6 NEW X0,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12,XP1,XP2,XAC,GOTCOM
+7 IF '$DATA(^LRO(68,+ACC,1,+ACCDT,1,+ACCN,0))
QUIT
SET X0=^(0)
SET XP1=$GET(^(.1))
SET XP2=$GET(^(.2))
SET X3=$GET(^(3))
+8 ;No matching entry in ^LR
IF '$DATA(^LR(+X0,0))
QUIT
+9 SET Y11=$SELECT($PIECE($GET(^LRO(69,+$PIECE(X0,"^",4),1,+$PIECE(X0,"^",5),0)),"^",11):$PIECE(^(0),"^",11),1:"")
SET Y12=$PIECE(X0,"^",10)
+10 IF '$DATA(DFN)
SET DFN=$PIECE(^LR(+X0,0),"^",3)
IF '$DATA(LRDFN)
SET LRDFN=+X0
IF '$DATA(LRDPF)
SET LRDPF=$PIECE(^LR(+X0,0),"^",2)_$GET(^DIC(+$PIECE(^LR(+X0,0),"^",2),0,"GL"))
+11 SET Y1=+XP1
SET Y2=+X3
SET Y3=""
SET Y4=""
SET Y5=$PIECE(X0,"^",4)
SET Y6=$PIECE(X0,"^",8)
SET Y7=$PIECE(X0,"^",7)
SET Y8=$PIECE(X3,"^",3)
SET Y9=$PIECE(X3,"^",4)
SET Y10=""
SET CTR=1
+12 SET ^TMP("LRX",$JOB,69)=Y1_"^"_Y2_"^"_Y3_"^"_Y4_"^"_Y5_"^"_Y6_"^"_Y7_"^"_Y8_"^"_Y9_"^"_Y10_"^"_Y11_"^"_Y12
+13 SET Y1=+XP1
SET Y2=$PIECE(X0,"^")
SET Y3=XP2
SET Y4=$PIECE(X3,"^")
SET Y5=$PIECE(X3,"^",3)
SET Y6=$PIECE(X3,"^",4)
SET Y7=$PIECE(X3,"^",5)
+14 SET XAC=$PIECE($GET(^LRO(68,ACC,0)),"^",2)
SET X=$SELECT(XAC="CY":$ORDER(^LAB(60,"B","CYTOPATHOLOGY",0)),XAC="EM":$ORDER(^LAB(60,"B","ELECTRON MICROSCOPY",0)),XAC="AU":$ORDER(^LAB(60,"B","AUTOPSY",0)),XAC="SP":$ORDER(^LAB(60,"B","SURGICAL PATHOLOGY",0)),1:"")
+15 IF X=""
SET X=$SELECT(XAC="CY":"CYTOPATHOLOGY",XAC="EM":"ELECTRON MICROSCOPY",XAC="AU":"AUTOPSY",XAC="SP":"SURGICAL PATHOLOGY",1:"")
+16 SET ^TMP("LRX",$JOB,69,CTR)=X_"^^"_ACCDT_"^"_ACC_"^"_ACCN
+17 SET ^TMP("LRX",$JOB,69,CTR,68)=Y1_"^"_Y2_"^"_Y3_"^"_Y4_"^"_Y5_"^"_Y6_"^"_Y7
+18 SET TEST=0
FOR
SET TEST=$ORDER(^LRO(68,ACC,1,ACCDT,1,ACCN,4,TEST))
IF TEST<1
QUIT
SET X=^(TEST,0)
SET ^TMP("LRX",$JOB,69,CTR,68,TEST)=+X_"^"_$PIECE(X,"^",2)_"^"_$PIECE(X,"^",4)_"^"_$PIECE(X,"^",5)
DO 63^LR7OB63(CTR,Y2,XAC,Y7,+$GET(CORRECT))
+19 QUIT
