- LRAPL ; IHS/DIR/AAB - ANATOMIC PATH LABELS 2/13/98 12:27 ; [ 07/08/1998 10:00 AM ]
- ;;5.2;LR;**1002,1006**;SEP 01, 1998
- ;
- ;;5.2;LAB SERVICE;**72,201**;Sep 27, 1994
- S LRDICS="SPCYEM" D ^LRAP G:'$D(Y) END
- ASK S %DT="",X="T" D ^%DT S LR(5)=$E(Y,1,3)+1700 W !,"Enter year: ",LR(5),"// " R X:DTIME G:'$T!(X[U) END S:X="" X=LR(5)
- S %DT="EQ" D ^%DT G:X["?" ASK G:Y<1 END S LR(2)=$E(Y,1,3) W " ",LR(2)+1700
- R R !!,"Start with accession number: ",X:DTIME G:X=""!(X[U) END S LR(3)=X I +X'=X D HELP G R
- RR R !,"Go to accession number: LAST// ",LR(4):DTIME G:'$T!(LR(4)[U) END S:LR(4)="" LR(4)=9999999 I LR(4)'=+LR(4) D HELP G RR
- S:'LR(4) LR(4)=9999999
- I LR(4)<LR(3) S X=LR(3),LR(3)=LR(4),LR(4)=X
- W !!?33,"REMEMBER TO",!?13,"ALIGN THE PRINT HEAD ON THE FIRST LINE OF THE LABEL"
- S LR(3)=LR(3)-1,LR(1)=$S($D(^LRO(69.2,LRAA,0)):$P(^(0),U,7),1:"")
- I W !!?20,"ENTER NUMBER OF LINES FROM",!?20,"TOP OF ONE LABEL TO ANOTHER: ",LR(1),$S(LR(1):"// ",1:"") R X:DTIME Q:'$T!(X[U) S X=$S(X="":LR(1),$L(X)>2:X=1,1:X)
- A X $P(^DD(69.2,.07,0),U,5,99) I '$D(X) W:$D(^DD(69.2,.07,3)) !,$C(7),^(3) X:$D(^(4)) ^(4) G I
- I X["?" S X="ZZZ" G A
- S LR(1)=X
- S ZTRTN="QUE^LRAPL",ZTDESC="Anatomic Path Labels",ZTSAVE("LR*")="" D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO D XR^LRU
- F A=LR(3):0 S A=$O(^LR(LRXREF,LR(2),LRABV,A)) Q:'A!(A>LR(4)) S LRDFN=+$O(^(A,0)),LRI=+$O(^(LRDFN,0)) D W
- D END^LRUTL,END Q
- W S LRX=$G(^LR(LRDFN,LRSS,LRI,0)) I LRX="" K ^LR(LRXREF,LR(2),LRABV,A,LRDFN,LRI) Q
- Q:$P($P(LRX,U,6)," ")'=LRABV
- ;S W=^LR(LRDFN,0),Y=$P(W,"^",3),(LRDPF,P)=$P(W,"^",2),X=^DIC(P,0,"GL"),X=@(X_Y_",0)") S P(1)=$P(X,"^"),SSN=$P(X,"^",9),S(6)=$P(LRX,"^",6),LRSPECDT=+LRX D SSN^LRU
- S W=^LR(LRDFN,0),(DFN,Y)=$P(W,"^",3),(LRDPF,P)=$P(W,"^",2),X=^DIC(P,0,"GL"),X=@(X_Y_",0)") S P(1)=$P(X,"^"),SSN=$P(X,"^",9),S(6)=$P(LRX,"^",6),LRSPECDT=+LRX D SSN^LRU ;IHS/ANMC/CLS 11/1/95
- F B=0:0 S B=$O(^LR(LRDFN,LRSS,LRI,.1,B)) Q:'B S S(2)=^(B,0) D P
- Q
- P W !,S(6)," Taken: ",$$FMTE^XLFDT(LRSPECDT,"D")
- ;W !,P(1)," ",SSN
- W !,P(1)," ",HRCN ;IHS/ANMC/CLS 11/1/95
- W !,$P(S(2),"^") F X=4:1:LR(1) W !
- Q
- HELP W $C(7),!!,"Enter numbers only",! Q
- END K LRSPECDT D V^LRU Q
- LRAPL ; IHS/DIR/AAB - ANATOMIC PATH LABELS 2/13/98 12:27 ; [ 07/08/1998 10:00 AM ]
- +1 ;;5.2;LR;**1002,1006**;SEP 01, 1998
- +2 ;
- +3 ;;5.2;LAB SERVICE;**72,201**;Sep 27, 1994
- +4 SET LRDICS="SPCYEM"
- DO ^LRAP
- IF '$DATA(Y)
- GOTO END
- ASK SET %DT=""
- SET X="T"
- DO ^%DT
- SET LR(5)=$EXTRACT(Y,1,3)+1700
- WRITE !,"Enter year: ",LR(5),"// "
- READ X:DTIME
- IF '$TEST!(X[U)
- GOTO END
- IF X=""
- SET X=LR(5)
- +1 SET %DT="EQ"
- DO ^%DT
- IF X["?"
- GOTO ASK
- IF Y<1
- GOTO END
- SET LR(2)=$EXTRACT(Y,1,3)
- WRITE " ",LR(2)+1700
- R READ !!,"Start with accession number: ",X:DTIME
- IF X=""!(X[U)
- GOTO END
- SET LR(3)=X
- IF +X'=X
- DO HELP
- GOTO R
- RR READ !,"Go to accession number: LAST// ",LR(4):DTIME
- IF '$TEST!(LR(4)[U)
- GOTO END
- IF LR(4)=""
- SET LR(4)=9999999
- IF LR(4)'=+LR(4)
- DO HELP
- GOTO RR
- +1 IF 'LR(4)
- SET LR(4)=9999999
- +2 IF LR(4)<LR(3)
- SET X=LR(3)
- SET LR(3)=LR(4)
- SET LR(4)=X
- +3 WRITE !!?33,"REMEMBER TO",!?13,"ALIGN THE PRINT HEAD ON THE FIRST LINE OF THE LABEL"
- +4 SET LR(3)=LR(3)-1
- SET LR(1)=$SELECT($DATA(^LRO(69.2,LRAA,0)):$PIECE(^(0),U,7),1:"")
- I WRITE !!?20,"ENTER NUMBER OF LINES FROM",!?20,"TOP OF ONE LABEL TO ANOTHER: ",LR(1),$SELECT(LR(1):"// ",1:"")
- READ X:DTIME
- IF '$TEST!(X[U)
- QUIT
- SET X=$SELECT(X="":LR(1),$LENGTH(X)>2:X=1,1:X)
- A XECUTE $PIECE(^DD(69.2,.07,0),U,5,99)
- IF '$DATA(X)
- IF $DATA(^DD(69.2,.07,3))
- WRITE !,$CHAR(7),^(3)
- IF $DATA(^(4))
- XECUTE ^(4)
- GOTO I
- +1 IF X["?"
- SET X="ZZZ"
- GOTO A
- +2 SET LR(1)=X
- +3 SET ZTRTN="QUE^LRAPL"
- SET ZTDESC="Anatomic Path Labels"
- SET ZTSAVE("LR*")=""
- DO BEG^LRUTL
- IF POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- DO XR^LRU
- +1 FOR A=LR(3):0
- SET A=$ORDER(^LR(LRXREF,LR(2),LRABV,A))
- IF 'A!(A>LR(4))
- QUIT
- SET LRDFN=+$ORDER(^(A,0))
- SET LRI=+$ORDER(^(LRDFN,0))
- DO W
- +2 DO END^LRUTL
- DO END
- QUIT
- W SET LRX=$GET(^LR(LRDFN,LRSS,LRI,0))
- IF LRX=""
- KILL ^LR(LRXREF,LR(2),LRABV,A,LRDFN,LRI)
- QUIT
- +1 IF $PIECE($PIECE(LRX,U,6)," ")'=LRABV
- QUIT
- +2 ;S W=^LR(LRDFN,0),Y=$PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P(W,"^",3),(LRDPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PF,PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P)=$PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P(W,"^",2),X=^DIC(PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P,0,"GL"),X=@(X_Y_",0)") S PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P(1)=$PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P(X,"^"),SSN=$PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P(X,"^",9),S(6)=$PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P(LRX,"^",6),LRSPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">P">PL_source.html#xP">PL_source.html#xPL_source.html#xP">P">PL_source.html#xP">PECDT=+LRX D SSN^LRU
- +3 ;IHS/ANMC/CLS 11/1/95
- SET W=^LR(LRDFN,0)
- SET (DFN,Y)=$PIECE(W,"^",3)
- SET (LRDPF,P)=$PIECE(W,"^",2)
- SET X=^DIC(P,0,"GL")
- SET X=@(X_Y_",0)")
- SET P(1)=$PIECE(X,"^")
- SET SSN=$PIECE(X,"^",9)
- SET S(6)=$PIECE(LRX,"^",6)
- SET LRSPECDT=+LRX
- DO SSN^LRU
- +4 FOR B=0:0
- SET B=$ORDER(^LR(LRDFN,LRSS,LRI,.1,B))
- IF 'B
- QUIT
- SET S(2)=^(B,0)
- DO P
- +5 QUIT
- P WRITE !,S(6)," Taken: ",$$FMTE^XLFDT(LRSPECDT,"D")
- +1 ;W !,P(1)," ",SSN
- +2 ;IHS/ANMC/CLS 11/1/95
- WRITE !,P(1)," ",HRCN
- +3 WRITE !,$PIECE(S(2),"^")
- FOR X=4:1:LR(1)
- WRITE !
- +4 QUIT
- HELP WRITE $CHAR(7),!!,"Enter numbers only",!
- QUIT
- END KILL LRSPECDT
- DO V^LRU
- QUIT
