- LRRP ;DALOI/RWF/BA - PROCESS DATA FOR INTERIM REPORTS ; 24-Nov-2014 09:20 ; MKK
- ;;5.2;LAB SERVICE;**195,221,283,286,1027,1034**;NOV 01, 1997;Build 88
- ;
- SET ;from LRRSP, LRRS, LRRD - call with LRORDER=ORDERS, LRODT=DATE, LRDFN
- K ^TMP("LR",$J,"TP"),LRORD
- S:'$D(LRTSCRN) LRTSCRN=0
- S LRLAB=$S($D(LRLABKY):1,1:0),LRHF=1,LRFOOT=0,LRCW=8 Q:'$D(LRODT)
- F LROP=1:1 S LRORD(1)=$P(LRORDER,U,LROP) D TEST Q:LRSTOP!LREND!(LRORD(1)="")
- I 'LREND,'LRSTOP,LRFOOT D FOOT^LRRP1
- K ^TMP("LR",$J,"TP"),LRORD
- Q
- ;
- ;
- TEST ;
- I LRORD(1)="" K ^TMP("LR",$J,"TP") Q
- S LRFOUND=1,LRORD=$S($D(^LRO(69,LRODT,1,LRORD(1),0))#2:^(0),1:"") Q:LRORD=""!(+LRORD'=LRDFN)
- K S,LRAAO S LRTEST=0
- F S LRTEST=+$O(^LRO(69,LRODT,1,LRORD(1),2,LRTEST)) Q:LRTEST<1 S X=^(LRTEST,0) I LRTSCRN=0!(LRTSCRN=+X) D DATA K S
- K S Q:'$D(LRAAO) Q:LRAAO<.1
- S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX
- S LROC=$S($D(^LR(LRDFN,.1)):^(.1),LRDPF=2&$D(^DPT(DFN,.1)):^(.1),1:"FILE ROOM")
- D ^LRRP1
- Q
- ;
- ;
- DATA S LRTSTS=+X,LRAD=$P(X,U,3),LRAA=+$P(X,U,4),LRAN=$P(X,U,5)
- S LRAAO=$S($D(^LRO(68,LRAA,0)):$P(^(0),U,8),1:0)
- I LRAAO<.1 Q:'LRAA D Q
- . W !?2,$C(7),$P(^LRO(68,LRAA,0),"^")_" accession area is missing a print order!",!?2,$P(^LAB(60,LRTSTS,0),"^")_" results will not be displayed until this is corrected.",!?2,"Please contact IRM or the Lab ADPAC."
- S LRSS=$P(^LRO(68,LRAA,0),U,2)
- Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) Q:'$D(^(3))
- S ^TMP("LR",$J,"TP",LRAAO)=LRAA_U_LRSS
- S LRCDT=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U)
- S LRIDT=+$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,5)
- I 'LRIDT S LRIDT=9999999-LRCDT
- S ^TMP("LR",$J,"TP",LRAAO,LRCDT,-1)=$S($D(^TMP("LR",$J,"TP",LRAAO,-1)):^(-1),1:"")_LRTSTS_U
- S ^TMP("LR",$J,"TP",LRAAO,LRCDT,-2)=LRIDT
- Q:LRSS="MI"
- S (S,J)=0
- F S J=+$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,J)) Q:J<1 S:^(J,0)>0 S=S+1,S(S)=+^(0)
- S LR0=$S($D(^LR(LRDFN,LRSS,LRIDT,0)):^(0),1:""),LRSPEC=+$P(LR0,U,5),(LRTC,LRLLT)=0
- F S LRLLT=+$O(S(LRLLT)) Q:LRLLT<1 S LRTSTS=+S(LRLLT) D XPND
- D CMNT
- Q
- ;
- ;
- XPND Q:'$D(^LAB(60,LRTSTS,.1)) S LRDN=$P($P(^(0),U,5),";",2)
- I '$L(LRDN) S LRJJ=0 F S LRJJ=+$O(^LAB(60,LRTSTS,2,LRJJ)) Q:LRJJ<1 S S=S+1,S(S)=+^(LRJJ,0)
- D:$L(LRDN) SETUP
- Q
- ;
- ;
- SETUP Q:'LRTSTS Q:'$D(^LAB(60,LRTSTS,.1)) S X=^(.1)
- I 'LRLAB,"BO"'[$P(^LAB(60,LRTSTS,0),U,3) Q
- ; Q:'$D(^LR(LRDFN,LRSS,LRIDT,LRDN)) Q:'$L($P(^(LRDN),U))
- Q:'$D(^LR(LRDFN,LRSS,LRIDT,LRDN)) Q:'$L($P($G(^(LRDN)),U)) ; IHS/MSC/MKK - LR*5.2*1034
- ;
- S LRPO=$P(X,U,6),LRPO=$S(LRPO:LRPO,1:LRDN/1000000)
- F Q:'$D(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO)) Q:LRTSTS=+^(LRPO) S LRPO=LRPO+1
- Q:$D(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO))
- S ^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO)=LRTSTS_U_$P(^LAB(60,LRTSTS,0),U)_U_$P(X,U)_U_$P(X,U,2)_U_$P(X,U,3)_U_$P(^(0),U,5)_U_$P(^LR(LRDFN,LRSS,LRIDT,LRDN),U)_U_$P(^(LRDN),U,2)_U_$P(^(LRDN),U,9)_U_LRDN,LRTC=LRTC+1
- ;
- I $D(^LAB(60,LRTSTS,1,LRSPEC,1,0)) D
- . S LRINTP=0
- . F S LRINTP=+$O(^LAB(60,LRTSTS,1,LRSPEC,1,LRINTP)) Q:LRINTP<1 S ^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO,LRINTP)=^(LRINTP,0) S LRTC=LRTC+1
- Q
- ;
- ;
- CMNT ;
- S ^TMP("LR",$J,"TP",LRAAO)=LRAA_U_LRSS,^(LRAAO,LRCDT)=LR0,^(LRCDT,-1)=""
- S ^TMP("LR",$J,"TP",LRAAO,LRCDT,-2)=LRIDT
- ;
- S LRCMNT=0 F I=0:0 S LRCMNT=+$O(^LR(LRDFN,LRSS,LRIDT,1,LRCMNT)) Q:LRCMNT<1 S ^TMP("LR",$J,"TP",LRAAO,LRCDT,"C",LRCMNT)=^(LRCMNT,0) S LRTC=LRTC+1
- S $P(^TMP("LR",$J,"TP",LRAAO,LRCDT),U,12)=LRTC
- Q
- ;
- ;
- CH ;from LRRP2
- S LRDN=1
- F S LRDN=$O(^LR(LRDFN,"CH",LRIDT,LRDN)) Q:LRDN<1 S LRTSTS=$O(^LAB(60,"C","CH;"_LRDN_";1",0)) D SETUP
- D CMNT,^LRRP1
- Q
- ;
- ;
- GO ;from LRRP3
- S LRLAB=$S($D(LRLABKY):1,1:0),LRDN=1
- F S LRDN=$O(^TMP("LR",$J,"TMP",LRDN)) Q:LRDN<1 S LRTSTS=+^(LRDN) D SETUP
- D CMNT,^LRRP1
- Q
- LRRP ;DALOI/RWF/BA - PROCESS DATA FOR INTERIM REPORTS ; 24-Nov-2014 09:20 ; MKK
- +1 ;;5.2;LAB SERVICE;**195,221,283,286,1027,1034**;NOV 01, 1997;Build 88
- +2 ;
- SET ;from LRRSP, LRRS, LRRD - call with LRORDER=ORDERS, LRODT=DATE, LRDFN
- +1 KILL ^TMP("LR",$JOB,"TP"),LRORD
- +2 IF '$DATA(LRTSCRN)
- SET LRTSCRN=0
- +3 SET LRLAB=$SELECT($DATA(LRLABKY):1,1:0)
- SET LRHF=1
- SET LRFOOT=0
- SET LRCW=8
- IF '$DATA(LRODT)
- QUIT
- +4 FOR LROP=1:1
- SET LRORD(1)=$PIECE(LRORDER,U,LROP)
- DO TEST
- IF LRSTOP!LREND!(LRORD(1)="")
- QUIT
- +5 IF 'LREND
- IF 'LRSTOP
- IF LRFOOT
- DO FOOT^LRRP1
- +6 KILL ^TMP("LR",$JOB,"TP"),LRORD
- +7 QUIT
- +8 ;
- +9 ;
- TEST ;
- +1 IF LRORD(1)=""
- KILL ^TMP("LR",$JOB,"TP")
- QUIT
- +2 SET LRFOUND=1
- SET LRORD=$SELECT($DATA(^LRO(69,LRODT,1,LRORD(1),0))#2:^(0),1:"")
- IF LRORD=""!(+LRORD'=LRDFN)
- QUIT
- +3 KILL S,LRAAO
- SET LRTEST=0
- +4 FOR
- SET LRTEST=+$ORDER(^LRO(69,LRODT,1,LRORD(1),2,LRTEST))
- IF LRTEST<1
- QUIT
- SET X=^(LRTEST,0)
- IF LRTSCRN=0!(LRTSCRN=+X)
- DO DATA
- KILL S
- +5 KILL S
- IF '$DATA(LRAAO)
- QUIT
- IF LRAAO<.1
- QUIT
- +6 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
- SET DFN=$PIECE(^(0),U,3)
- DO PT^LRX
- +7 SET LROC=$SELECT($DATA">DATA(^LR(LRDFN,.1)):^(.1),LRDPF=2&$DATA">DATA(^DPT(DFN,.1)):^(.1),1:"FILE ROOM")
- +8 DO ^LRRP1
- +9 QUIT
- +10 ;
- +11 ;
- DATA SET LRTSTS=+X
- SET LRAD=$PIECE(X,U,3)
- SET LRAA=+$PIECE(X,U,4)
- SET LRAN=$PIECE(X,U,5)
- +1 SET LRAAO=$SELECT($DATA(^LRO(68,LRAA,0)):$PIECE(^(0),U,8),1:0)
- +2 IF LRAAO<.1
- IF 'LRAA
- QUIT
- Begin DoDot:1
- +3 WRITE !?2,$CHAR(7),$PIECE(^LRO(68,LRAA,0),"^")_" accession area is missing a print order!",!?2,$PIECE(^LAB(60,LRTSTS,0),"^")_" results will not be displayed until this is corrected.",!?2,"Please contact IRM or the Lab ADPAC."
- End DoDot:1
- QUIT
- +4 SET LRSS=$PIECE(^LRO(68,LRAA,0),U,2)
- +5 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
- QUIT
- IF '$DATA(^(3))
- QUIT
- +6 SET ^TMP("LR",$JOB,"TP",LRAAO)=LRAA_U_LRSS
- +7 SET LRCDT=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U)
- +8 SET LRIDT=+$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,5)
- +9 IF 'LRIDT
- SET LRIDT=9999999-LRCDT
- +10 SET ^TMP("LR",$JOB,"TP",LRAAO,LRCDT,-1)=$SELECT($DATA(^TMP("LR",$JOB,"TP",LRAAO,-1)):^(-1),1:"")_LRTSTS_U
- +11 SET ^TMP("LR",$JOB,"TP",LRAAO,LRCDT,-2)=LRIDT
- +12 IF LRSS="MI"
- QUIT
- +13 SET (S,J)=0
- +14 FOR
- SET J=+$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,J))
- IF J<1
- QUIT
- IF ^(J,0)>0
- SET S=S+1
- SET S(S)=+^(0)
- +15 SET LR0=$SELECT($DATA(^LR(LRDFN,LRSS,LRIDT,0)):^(0),1:"")
- SET LRSPEC=+$PIECE(LR0,U,5)
- SET (LRTC,LRLLT)=0
- +16 FOR
- SET LRLLT=+$ORDER(S(LRLLT))
- IF LRLLT<1
- QUIT
- SET LRTSTS=+S(LRLLT)
- DO XPND
- +17 DO CMNT
- +18 QUIT
- +19 ;
- +20 ;
- XPND IF '$DATA(^LAB(60,LRTSTS,.1))
- QUIT
- SET LRDN=$PIECE($PIECE(^(0),U,5),";",2)
- +1 IF '$LENGTH(LRDN)
- SET LRJJ=0
- FOR
- SET LRJJ=+$ORDER(^LAB(60,LRTSTS,2,LRJJ))
- IF LRJJ<1
- QUIT
- SET S=S+1
- SET S(S)=+^(LRJJ,0)
- +2 IF $LENGTH(LRDN)
- DO SETUP
- +3 QUIT
- +4 ;
- +5 ;
- SETUP IF 'LRTSTS
- QUIT
- IF '$DATA(^LAB(60,LRTSTS,.1))
- QUIT
- SET X=^(.1)
- +1 IF 'LRLAB
- IF "BO"'[$PIECE(^LAB(60,LRTSTS,0),U,3)
- QUIT
- +2 ; Q:'$D(^LR(LRDFN,LRSS,LRIDT,LRDN)) Q:'$L($P(^(LRDN),U))
- +3 ; IHS/MSC/MKK - LR*5.2*1034
- IF '$DATA(^LR(LRDFN,LRSS,LRIDT,LRDN))
- QUIT
- IF '$LENGTH($PIECE($GET(^(LRDN)),U))
- QUIT
- +4 ;
- +5 SET LRPO=$PIECE(X,U,6)
- SET LRPO=$SELECT(LRPO:LRPO,1:LRDN/1000000)
- +6 FOR
- IF '$DATA(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO))
- QUIT
- IF LRTSTS=+^(LRPO)
- QUIT
- SET LRPO=LRPO+1
- +7 IF $DATA(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO))
- QUIT
- +8 SET ^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO)=LRTSTS_U_$PIECE(^LAB(60,LRTSTS,0),U)_U_$PIECE(X,U)_U_$PIECE(X,U,2)_U_$PIECE(X,U,3)_U_$PIECE(^(0),U,5)_U_$PIECE(^LR(LRDFN,LRSS,LRIDT,LRDN),U)_U_$PIECE(^(LRDN),U,2)_U_$PIECE(^(LRDN),U,9)_U_LRDN
- SET LRTC=LRTC+1
- +9 ;
- +10 IF $DATA(^LAB(60,LRTSTS,1,LRSPEC,1,0))
- Begin DoDot:1
- +11 SET LRINTP=0
- +12 FOR
- SET LRINTP=+$ORDER(^LAB(60,LRTSTS,1,LRSPEC,1,LRINTP))
- IF LRINTP<1
- QUIT
- SET ^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO,LRINTP)=^(LRINTP,0)
- SET LRTC=LRTC+1
- End DoDot:1
- +13 QUIT
- +14 ;
- +15 ;
- CMNT ;
- +1 SET ^TMP("LR",$JOB,"TP",LRAAO)=LRAA_U_LRSS
- SET ^(LRAAO,LRCDT)=LR0
- SET ^(LRCDT,-1)=""
- +2 SET ^TMP("LR",$JOB,"TP",LRAAO,LRCDT,-2)=LRIDT
- +3 ;
- +4 SET LRCMNT=0
- FOR I=0:0
- SET LRCMNT=+$ORDER(^LR(LRDFN,LRSS,LRIDT,1,LRCMNT))
- IF LRCMNT<1
- QUIT
- SET ^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C",LRCMNT)=^(LRCMNT,0)
- SET LRTC=LRTC+1
- +5 SET $PIECE(^TMP("LR",$JOB,"TP",LRAAO,LRCDT),U,12)=LRTC
- +6 QUIT
- +7 ;
- +8 ;
- CH ;from LRRP2
- +1 SET LRDN=1
- +2 FOR
- SET LRDN=$ORDER(^LR(LRDFN,"CH",LRIDT,LRDN))
- IF LRDN<1
- QUIT
- SET LRTSTS=$ORDER(^LAB(60,"C","CH;"_LRDN_";1",0))
- DO SETUP
- +3 DO CMNT
- DO ^LRRP1
- +4 QUIT
- +5 ;
- +6 ;
- GO ;from LRRP3
- +1 SET LRLAB=$SELECT($DATA(LRLABKY):1,1:0)
- SET LRDN=1
- +2 FOR
- SET LRDN=$ORDER(^TMP("LR",$JOB,"TMP",LRDN))
- IF LRDN<1
- QUIT
- SET LRTSTS=+^(LRDN)
- DO SETUP
- +3 DO CMNT
- DO ^LRRP1
- +4 QUIT
