- LRAPBS ; IHS/DIR/AAB - BLOCK/SLIDE DATA ENTRY 8/15/95 11:14 ;
- ;;5.2;LR;**1002**;JUN 01, 1998
- ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- D ^LRAP G:'$D(Y) END K DR,Y D A^LRAPWU,S^LRAPST W !! D @LRSS G END
- ;
- SP S (LRK(1),LRK)="",J=0 D:LRCAPA SP^LRAPBS1 Q:J F X=1,2,3 S Y(X)=$P(^DD(63.812,X,0),"^") W !?15,X,". ",Y(X)
- S Z="",B=1 F A=0:0 W !,"Selection (",B,"): " R X:DTIME Q:X=""!(X[U) D:X<1!(X>3)!(X'=+X) HELP I X>0&(X<4)&(X=+X) W " ",Y(X) S:Z'[X Z=Z_X_";" S B=B+1 Q:B=4
- Q:X[U I Z="" S Z="1;2;3" W " All selected."
- S DR=.012,(DR(3,63.8121),DR(3,63.822))=".01;.02//^S X=LRK(1);.04;1//^S X=""H & E STAIN""",DR(3,63.824)=".01;.02//^S X=LRK(1);.04;1//^S X=""FROZEN SECTION H & E"""
- S (DR(4,63.8122),DR(4,63.823),DR(4,63.825))=".01;.02//1;.03;.04//^S X=LRK",DR(2,63.812)=Z D ^LRAPBS1 Q
- ;
- CY S (LRK,LRK(1))="" F X=1:1:5 S Y(X)=$P(^DD(63.902,X,0),"^") W !?15,X,". ",Y(X)
- S Z="",B=1 F A=0:0 W !,"Selection (",B,"): " R X:DTIME Q:X=""!(X[U) D:X<1!(X>5)!(X'=+X) HELP I X>0&(X<6)&(X=+X) W " ",Y(X) S:Z'[X Z=Z_X_";" S B=B+1 Q:B=6
- Q:X[U I Z="" S Z="1;2;3;4;5" W " All selected."
- S DR=.012,DR(3,63.9121)=".01;1//^S X=""PAP STAIN""",DR(3,63.922)=".01;1//^S X=""H & E STAIN""",DR(4,63.9122)=".01;.02;.03;.04//^S X=LRK",DR(4,63.923)=".01;.02;.03;.04//^S X=LRK"
- S (DR(63.9024),DR(3,9025))=".01;1//^S X=""PAP STAIN""",DR(3,63.924)=".01;1//^S X=""PAP STAIN,MEMBRANE FILTER""",(DR(4,63.9241),DR(4,63.90241),DR(4,63.90251))=".01;.02;.03;.04//^S X=LRK"
- S DR(2,63.902)=Z D ^LRAPBS1 Q
- ;
- EM S J=0,X="EM EMBEDDING" D X^LRUWK S LRW(1)=LRT K LRT Q:J
- S DR=.012,DR(3,63.2021)=".01;.02//^S X=LRK(1);1",DR(4,63.20211)=".01;.02;.04//^S X=LRK" F X=2:1:5 S LRW(X)=""
- S DR(2,63.202)=1 D ^LRAPBS1 Q
- AU D AU^LRAPBS1 Q:J S DR=33,DR(2,63.033)=".01;1",DR(3,63.331)=".01;.02//^S X=LRK(1);1",DR(4,63.3311)=".01;.02//1;.03;.04//^S X=LRK" D ^LRAPBS1 Q
- Q
- ;
- HELP W $C(7),!!,"Enter a number from 1 to ",$S(LRSS="SP":3,LRSS="CY":5,1:""),! Q
- ;
- EN S LRDICS="SP" D ^LRAP G:'$D(Y) END S LRF=1,J=0,LR(1)=$P(^DD(63.812,.04,0),U,3)
- S X="ROUTINE GROSS SURGICAL" D X^LRUWK S LRW(1)=LRT K LRT
- S X="EXTENSIVE GROSS SURGICAL" D X^LRUWK S LRW(2)=LRT K LRT
- S X="TECHNICAL ASSISTANCE SURGICAL" D X^LRUWK S LRW(3)=LRT K LRT
- Q:J S DR=.012,DR(2,63.812)=".04;.03//^S X=LRK" D ^LRAPBS1 Q
- ;
- END D V^LRU Q
- LRAPBS ; IHS/DIR/AAB - BLOCK/SLIDE DATA ENTRY 8/15/95 11:14 ;
- +1 ;;5.2;LR;**1002**;JUN 01, 1998
- +2 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- +3 DO ^LRAP
- IF '$DATA(Y)
- GOTO END
- KILL DR,Y
- DO A^LRAPWU
- DO S^LRAPST
- WRITE !!
- DO @LRSS
- GOTO END
- +4 ;
- SP SET (LRK(1),LRK)=""
- SET J=0
- IF LRCAPA
- DO SP^LRAPBS1
- IF J
- QUIT
- FOR X=1,2,3
- SET Y(X)=$PIECE(^DD(63.812,X,0),"^")
- WRITE !?15,X,". ",Y(X)
- +1 SET Z=""
- SET B=1
- FOR A=0:0
- WRITE !,"Selection (",B,"): "
- READ X:DTIME
- IF X=""!(X[U)
- QUIT
- IF X<1!(X>3)!(X'=+X)
- DO HELP
- IF X>0&(X<4)&(X=+X)
- WRITE " ",Y(X)
- IF Z'[X
- SET Z=Z_X_";"
- SET B=B+1
- IF B=4
- QUIT
- +2 IF X[U
- QUIT
- IF Z=""
- SET Z="1;2;3"
- WRITE " All selected."
- +3 SET DR=.012
- SET (DR(3,63.8121),DR(3,63.822))=".01;.02//^S X=LRK(1);.04;1//^S X=""H & E STAIN"""
- SET DR(3,63.824)=".01;.02//^S X=LRK(1);.04;1//^S X=""FROZEN SECTION H & E"""
- +4 SET (DR(4,63.8122),DR(4,63.823),DR(4,63.825))=".01;.02//1;.03;.04//^S X=LRK"
- SET DR(2,63.812)=Z
- DO ^LRAPBS1
- QUIT
- +5 ;
- CY SET (LRK,LRK(1))=""
- FOR X=1:1:5
- SET Y(X)=$PIECE(^DD(63.902,X,0),"^")
- WRITE !?15,X,". ",Y(X)
- +1 SET Z=""
- SET B=1
- FOR A=0:0
- WRITE !,"Selection (",B,"): "
- READ X:DTIME
- IF X=""!(X[U)
- QUIT
- IF X<1!(X>5)!(X'=+X)
- DO HELP
- IF X>0&(X<6)&(X=+X)
- WRITE " ",Y(X)
- IF Z'[X
- SET Z=Z_X_";"
- SET B=B+1
- IF B=6
- QUIT
- +2 IF X[U
- QUIT
- IF Z=""
- SET Z="1;2;3;4;5"
- WRITE " All selected."
- +3 SET DR=.012
- SET DR(3,63.9121)=".01;1//^S X=""PAP STAIN"""
- SET DR(3,63.922)=".01;1//^S X=""H & E STAIN"""
- SET DR(4,63.9122)=".01;.02;.03;.04//^S X=LRK"
- SET DR(4,63.923)=".01;.02;.03;.04//^S X=LRK"
- +4 SET (DR(63.9024),DR(3,9025))=".01;1//^S X=""PAP STAIN"""
- SET DR(3,63.924)=".01;1//^S X=""PAP STAIN,MEMBRANE FILTER"""
- SET (DR(4,63.9241),DR(4,63.90241),DR(4,63.90251))=".01;.02;.03;.04//^S X=LRK"
- +5 SET DR(2,63.902)=Z
- DO ^LRAPBS1
- QUIT
- +6 ;
- EM SET J=0
- SET X="EM EMBEDDING"
- DO X^LRUWK
- SET LRW(1)=LRT
- KILL LRT
- IF J
- QUIT
- +1 SET DR=.012
- SET DR(3,63.2021)=".01;.02//^S X=LRK(1);1"
- SET DR(4,63.20211)=".01;.02;.04//^S X=LRK"
- FOR X=2:1:5
- SET LRW(X)=""
- +2 SET DR(2,63.202)=1
- DO ^LRAPBS1
- QUIT
- AU DO AU^LRAPBS1
- IF J
- QUIT
- SET DR=33
- SET DR(2,63.033)=".01;1"
- SET DR(3,63.331)=".01;.02//^S X=LRK(1);1"
- SET DR(4,63.3311)=".01;.02//1;.03;.04//^S X=LRK"
- DO ^LRAPBS1
- QUIT
- +1 QUIT
- +2 ;
- HELP WRITE $CHAR(7),!!,"Enter a number from 1 to ",$SELECT(LRSS="SP":3,LRSS="CY":5,1:""),!
- QUIT
- +1 ;
- EN SET LRDICS="SP"
- DO ^LRAP
- IF '$DATA(Y)
- GOTO END
- SET LRF=1
- SET J=0
- SET LR(1)=$PIECE(^DD(63.812,.04,0),U,3)
- +1 SET X="ROUTINE GROSS SURGICAL"
- DO X^LRUWK
- SET LRW(1)=LRT
- KILL LRT
- +2 SET X="EXTENSIVE GROSS SURGICAL"
- DO X^LRUWK
- SET LRW(2)=LRT
- KILL LRT
- +3 SET X="TECHNICAL ASSISTANCE SURGICAL"
- DO X^LRUWK
- SET LRW(3)=LRT
- KILL LRT
- +4 IF J
- QUIT
- SET DR=.012
- SET DR(2,63.812)=".04;.03//^S X=LRK"
- DO ^LRAPBS1
- QUIT
- +5 ;
- END DO V^LRU
- QUIT
