- 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
