- LRAPPF ;AVAMC/REG - ANATOMIC PATH FILE SORT ;8/13/95 21:59 ;
- ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- D ^LRAP G:'$D(Y) END W !!?10,LRO(68),!?10,"Entries by Patient & Accession # Index",!! D B^LRU G:Y<0 END
- S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99
- S ZTRTN="QUE^LRAPPF" D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO K ^TMP($J) S S=LRSS D XR^LRU,L^LRU,S^LRU,EN^LRUA
- F A=0:0 S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) D L
- D ^LRAPPF1 K ^TMP($J) D END^LRUTL,END Q
- L F LRDFN=0:0 S LRDFN=$O(^LR(LRXR,LRSDT,LRDFN)) Q:'LRDFN D P
- Q
- P I '$D(^LR(LRDFN,0)) K ^LR(LRXR,LRSDT,LRDFN) Q
- S F=$P(^LR(LRDFN,0),"^",2),N=$P(^(0),"^",3),F(1)=$S(F=2:"",1:$P(^DIC(F,0),"^")),X=^DIC(F,0,"GL"),N=@(X_N_",0)"),N(1)=$P(N,"^"),N(9)=$P(N,"^",9)
- I LRSS="AU" Q:$P($P($G(^LR(LRDFN,"AU")),U,6)," ")'=LRABV S Y=^("AU"),H(1)=+Y,H(2)=$E(H(1),1,3),LRI=9999999-H(1),N=+$P($P(Y,"^",6)," ",3) D GL Q
- F LRI=0:0 S LRI=$O(^LR(LRXR,LRSDT,LRDFN,LRI)) Q:'LRI I $P($P($G(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")=LRABV S X=^(0),H(2)=$E($P(X,"^",10),1,3),N=+$P($P(X,"^",6)," ",3) S:'H(2) H(2)="?" S:'N N="???" D GL
- Q
- GL S ^TMP($J,F,N(1),LRDFN,LRI)="",^TMP($J,"S",H(2),N)=F(1)_"^"_N(1)_"^"_N(9) Q
- ;
- END D V^LRU Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPPF 1181 printed Mar 13, 2025@21:12:10 Page 2
- LRAPPF ;AVAMC/REG - ANATOMIC PATH FILE SORT ;8/13/95 21:59 ;
- +1 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- +2 DO ^LRAP
- if '$DATA(Y)
- GOTO END
- WRITE !!?10,LRO(68),!?10,"Entries by Patient & Accession # Index",!!
- DO B^LRU
- if Y<0
- GOTO END
- +3 SET LRSDT=LRSDT-.01
- SET LRLDT=LRLDT+.99
- +4 SET ZTRTN="QUE^LRAPPF"
- DO BEG^LRUTL
- if POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- KILL ^TMP($JOB)
- SET S=LRSS
- DO XR^LRU
- DO L^LRU
- DO S^LRU
- DO EN^LRUA
- +1 FOR A=0:0
- SET LRSDT=$ORDER(^LR(LRXR,LRSDT))
- if 'LRSDT!(LRSDT>LRLDT)
- QUIT
- DO L
- +2 DO ^LRAPPF1
- KILL ^TMP($JOB)
- DO END^LRUTL
- DO END
- QUIT
- L FOR LRDFN=0:0
- SET LRDFN=$ORDER(^LR(LRXR,LRSDT,LRDFN))
- if 'LRDFN
- QUIT
- DO P
- +1 QUIT
- P IF '$DATA(^LR(LRDFN,0))
- KILL ^LR(LRXR,LRSDT,LRDFN)
- QUIT
- +1 SET F=$PIECE(^LR(LRDFN,0),"^",2)
- SET N=$PIECE(^(0),"^",3)
- SET F(1)=$SELECT(F=2:"",1:$PIECE(^DIC(F,0),"^"))
- SET X=^DIC(F,0,"GL")
- SET N=@(X_N_",0)")
- SET N(1)=$PIECE(N,"^")
- SET N(9)=$PIECE(N,"^",9)
- +2 IF LRSS="AU"
- if $PIECE($PIECE($GET(^LR(LRDFN,"AU")),U,6)," ")'=LRABV
- QUIT
- SET Y=^("AU")
- SET H(1)=+Y
- SET H(2)=$EXTRACT(H(1),1,3)
- SET LRI=9999999-H(1)
- SET N=+$PIECE($PIECE(Y,"^",6)," ",3)
- DO GL
- QUIT
- +3 FOR LRI=0:0
- SET LRI=$ORDER(^LR(LRXR,LRSDT,LRDFN,LRI))
- if 'LRI
- QUIT
- IF $PIECE($PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")=LRABV
- SET X=^(0)
- SET H(2)=$EXTRACT($PIECE(X,"^",10),1,3)
- SET N=+$PIECE($PIECE(X,"^",6)," ",3)
- if 'H(2)
- SET H(2)="?"
- if 'N
- SET N="???"
- DO GL
- +4 QUIT
- GL SET ^TMP($JOB,F,N(1),LRDFN,LRI)=""
- SET ^TMP($JOB,"S",H(2),N)=F(1)_"^"_N(1)_"^"_N(9)
- QUIT
- +1 ;
- END DO V^LRU
- QUIT
