LRAPBS ;AVAMC/REG - BLOCK/SLIDE DATA ENTRY ;11/18/11 15:15
;;5.2;LAB SERVICE;**72,350**;Sep 27, 1994;Build 230
;
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)=".06R;.07R;"_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)=".06R;.07R;"_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)=".06R;.07R;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPBS 2314 printed Dec 13, 2024@02:07:05 Page 2
LRAPBS ;AVAMC/REG - BLOCK/SLIDE DATA ENTRY ;11/18/11 15:15
+1 ;;5.2;LAB SERVICE;**72,350**;Sep 27, 1994;Build 230
+2 ;
+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)=".06R;.07R;"_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)=".06R;.07R;"_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)=".06R;.07R;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
