LRAPWE.m

LRAPWE ; IHS/DIR/AAB - DATE/TIME GRIDS SCANNED/PRINTS MADE 2/13/98 11:07 ; [ 2/13/98 9:20 AM ]

 ;;5.2;LR;**1002,1006**;SEP 01, 1998

 ;

 ;;5.2;LAB SERVICE;**72,201**;Sep 27, 1994

 S LRDICS="EM" D ^LRAP G:'$D(Y) END D EM^LRAPWE1 G:J END D S^LRAPST K Y

 W !!,"Ask 'Date/time grids scanned:' prompt for each accession " S %=2 D YN^LRU Q:%<1  S LRV=$S(%=2:0,1:1)

ASK S %DT="",X="T" D ^%DT S LRY=$E(Y,1,3)+1700 W !!,"Enter year: ",LRY,"// " R X:DTIME G:'$T!(X[U) END S:X="" X=LRY

 S %DT="EQ" D ^%DT G:Y<1 ASK S LRY=$E(Y,1,3),LRH(0)=LRY+1700 W "  ",LRH(0)

 S LRN="",LRAD=$E(LRY,1,3)_"0000"

 I '$O(^LRO(68,LRAA,1,LRAD,1,0)) W $C(7),!!,"NO ",LRO(68)," ACCESSIONS IN FILE FOR ",LRH(0),!! Q

W K LR("CK") W !!,"Select ",LRO(68)," Accession Number: ",LRN,$S(LRN:"//",1:"") R LRAN:DTIME G:'$T!(LRAN[U)!(LRN=""&(LRAN="")) END S:LRAN="" LRAN=LRN I LRAN'?1N.N S LRN="" W $C(7),!!,"Enter a number." G W

 S LRN=$O(^LRO(68,LRAA,1,LRAD,1,LRAN)) S:LRN'=+LRN LRN="" D REST G W

REST W "  for ",LRH(0) I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W $C(7),!!,"Accession # ",LRAN," for ",LRH(0)," not in ACCESSION file",!! Q

 S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRAC=$P($G(^(.2)),U),LRI=$P(^(3),U,5),LRDFN=+X Q:'$D(^LR(LRDFN,0))  S X=^(0) D ^LRUP

 S LRK(1)="" I LRV S %DT("A")="Date/time grids scanned: " D W^LRAPWU S:LRK<1 LRK="" S LRK(1)=LRK

 S %DT("A")="Date/time prints   made: " D W^LRAPWU S:LRK<1 LRK=""

 Q:'LRK(1)&('LRK)  D ^LRAPWU

 I F W $C(7),!!,"Use 'Blocks, Stains, Procedures, anat path' option to enter date",!,"grids (thin sections) processed. This must be done before entering date",!,"grids scanned, photos taken and prints made." Q

B Q:$D(LR("CK"))  K LR S LR=0 I '$D(IOF) S IOP="HOME" D ^%ZIS

 S LRA=^LR(LRDFN,LRSS,LRI,0),Y=+LRA D D^LRU S LRE=Y

 S LRM=0 D H F A=0:0 S A=$O(^LR(LRDFN,LRSS,LRI,.1,A)) Q:'A  S LRB=^(A,0) D:$Y>(IOSL-3) M Q:LRM[U  W !,$P(LRB,U) D S

 W !!,"Data displayed ok " S %=2 D YN^LRU Q:%<1  I %=1 D ^LRAPWE1 Q

 I LR S DIE="^LR(LRDFN,LRSS,",DA=LRI D CK^LRU Q:$D(LR("CK"))  W ! D ^LRAPWEA D FRE^LRU

 G B

S F E=0:0 S E=$O(^LR(LRDFN,LRSS,LRI,.1,A,E)) Q:'E  F B=0:0 S B=$O(^LR(LRDFN,LRSS,LRI,.1,A,E,B)) Q:'B!(LRM[U)  S LRB(1)=^(B,0) D:$Y>(IOSL-3) M Q:LRM[U  D T

 Q

T S Y=$G(^LR(LRDFN,LRSS,LRI,.1,A,E,B,1,LRW,0)) Q:Y=""  S X=$P(Y,U,2),Z=$P(Y,U,3),V=X+Z,LRZ(5)=$P(Y,U,5),LRZ(6)=$P(Y,U,6),LRZ(8)=$P(Y,U,8),LRZ(10)=$P(Y,U,10),LRZ(11)=$P(Y,U,11)

 S LR=LR+1,LR(LR)=A_U_E_U_B_U_V_U_LRZ(5)_U_LRZ(6)_U_LRZ(8)_U_LRZ(10)_U_LRZ(11)_U_$P(Y,U,13)_U_$P(Y,U,12)

 W !,"*",$J(LR,2),") ",$P(LRB(1),U),?15,$J(+LRZ(6),3),?24,$J(+LRZ(8),3),?33,$J(+LRZ(10),3),?40,$$FMTE^XLFDT(LRZ(5)),?60,$$FMTE^XLFDT(LRZ(11)) Q

 ;

M R !,"'^' TO STOP: ",LRM:DTIME S:'$T LRM=U D:LRM'[U H Q

H ;W @IOF,LRP," ",SSN(1)," Acc #: ",LRAC," Date: ",LRE,!,?15,"GRIDS",?24,"GRIDS",?32,"PRINTS",?40,"LAST DATE/TIME",?60,"LAST DATE/TIME"

 W @IOF,LRP," ",HRCN," Acc #: ",LRAC," Date: ",LRE,!,?15,"GRIDS",?24,"GRIDS",?32,"PRINTS",?40,"LAST DATE/TIME",?60,"LAST DATE/TIME"  ;IHS/ANMC/CLS 10/08/97

 W !?5,"BLOCK ID",?14,"PREPARED",?23,"SCANNED",?33,"MADE",?44,"SCANNED",?62,"PRINTS MADE" Q

 ;

END D V^LRU Q

LRAPWE    ; IHS/DIR/AAB - DATE/TIME GRIDS SCANNED/PRINTS MADE 2/13/98 11:07 ; [ 2/13/98 9:20 AM ]

 +1       ;;5.2;LR;**1002,1006**;SEP 01, 1998

 +2       ;

 +3       ;;5.2;LAB SERVICE;**72,201**;Sep 27, 1994

 +4        SET LRDICS="EM"

           DO ^LRAP

           IF '$DATA(Y)

               GOTO END

           DO EM^LRAPWE1

           IF J

               GOTO END

           DO S^LRAPST

           KILL Y

 +5        WRITE !!,"Ask 'Date/time grids scanned:' prompt for each accession "

           SET %=2

           DO YN^LRU

           IF %<1

               QUIT 

           SET LRV=$SELECT(%=2:0,1:1)

ASK        SET %DT=""

           SET X="T"

           DO ^%DT

           SET LRY=$EXTRACT(Y,1,3)+1700

           WRITE !!,"Enter year: ",LRY,"// "

           READ X:DTIME

           IF '$TEST!(X[U)

               GOTO END

           IF X=""

               SET X=LRY

 +1        SET %DT="EQ"

           DO ^%DT

           IF Y<1

               GOTO ASK

           SET LRY=$EXTRACT(Y,1,3)

           SET LRH(0)=LRY+1700

           WRITE "  ",LRH(0)

 +2        SET LRN=""

           SET LRAD=$EXTRACT(LRY,1,3)_"0000"

 +3        IF '$ORDER(^LRO(68,LRAA,1,LRAD,1,0))

               WRITE $CHAR(7),!!,"NO ",LRO(68)," ACCESSIONS IN FILE FOR ",LRH(0),!!

               QUIT 

W          KILL LR("CK")

           WRITE !!,"Select ",LRO(68)," Accession Number: ",LRN,$SELECT(LRN:"//",1:"")

           READ LRAN:DTIME

           IF '$TEST!(LRAN[U)!(LRN=""&(LRAN=""))

               GOTO END

           IF LRAN=""

               SET LRAN=LRN

           IF LRAN'?1N.N

               SET LRN=""

               WRITE $CHAR(7),!!,"Enter a number."

               GOTO W

 +1        SET LRN=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN))

           IF LRN'=+LRN

               SET LRN=""

           DO REST

           GOTO W

REST       WRITE "  for ",LRH(0)

           IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))

               WRITE $CHAR(7),!!,"Accession # ",LRAN," for ",LRH(0)," not in ACCESSION file",!!

               QUIT 

 +1        SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,0)

           SET LRAC=$PIECE($GET(^(.2)),U)

           SET LRI=$PIECE(^(3),U,5)

           SET LRDFN=+X

           IF '$DATA(^LR(LRDFN,0))

               QUIT 

           SET X=^(0)

           DO ^LRUP

 +2        SET LRK(1)=""

           IF LRV

               SET %DT("A")="Date/time grids scanned: "

               DO W^LRAPWU

               IF LRK<1

                   SET LRK=""

               SET LRK(1)=LRK

 +3        SET %DT("A")="Date/time prints   made: "

           DO W^LRAPWU

           IF LRK<1

               SET LRK=""

 +4        IF 'LRK(1)&('LRK)

               QUIT 

           DO ^LRAPWU

 +5        IF F

               WRITE $CHAR(7),!!,"Use 'Blocks, Stains, Procedures, anat path' option to enter date",!,"grids (thin sections) processed. This must be done before entering date",!,"grids scanned, photos taken and prints made."

               QUIT 

B          IF $DATA(LR("CK"))

               QUIT 

           KILL LR

           SET LR=0

           IF '$DATA(IOF)

               SET IOP="HOME"

               DO ^%ZIS

 +1        SET LRA=^LR(LRDFN,LRSS,LRI,0)

           SET Y=+LRA

           DO D^LRU

           SET LRE=Y

 +2        SET LRM=0

           DO H

           FOR A=0:0

               SET A=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A))

               IF 'A

                   QUIT 

               SET LRB=^(A,0)

               IF $Y>(IOSL-3)

                   DO M

               IF LRM[U

                   QUIT 

               WRITE !,$PIECE(LRB,U)

               DO S

 +3        WRITE !!,"Data displayed ok "

           SET %=2

           DO YN^LRU

           IF %<1

               QUIT 

           IF %=1

               DO ^LRAPWE1

               QUIT 

 +4        IF LR

               SET DIE="^LR(LRDFN,LRSS,"

               SET DA=LRI

               DO CK^LRU

               IF $DATA(LR("CK"))

                   QUIT 

               WRITE !

               DO ^LRAPWEA

               DO FRE^LRU

 +5        GOTO B

S          FOR E=0:0

               SET E=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A,E))

               IF 'E

                   QUIT 

               FOR B=0:0

                   SET B=$ORDER(^LR(LRDFN,LRSS,LRI,.1,A,E,B))

                   IF 'B!(LRM[U)

                       QUIT 

                   SET LRB(1)=^(B,0)

                   IF $Y>(IOSL-3)

                       DO M

                   IF LRM[U

                       QUIT 

                   DO T

 +1        QUIT 

T          SET Y=$GET(^LR(LRDFN,LRSS,LRI,.1,A,E,B,1,LRW,0))

           IF Y=""

               QUIT 

           SET X=$PIECE(Y,U,2)

           SET Z=$PIECE(Y,U,3)

           SET V=X+Z

           SET LRZ(5)=$PIECE(Y,U,5)

           SET LRZ(6)=$PIECE(Y,U,6)

           SET LRZ(8)=$PIECE(Y,U,8)

           SET LRZ(10)=$PIECE(Y,U,10)

           SET LRZ(11)=$PIECE(Y,U,11)

 +1        SET LR=LR+1

           SET LR(LR)=A_U_E_U_B_U_V_U_LRZ(5)_U_LRZ(6)_U_LRZ(8)_U_LRZ(10)_U_LRZ(11)_U_$PIECE(Y,U,13)_U_$PIECE(Y,U,12)

 +2        WRITE !,"*",$JUSTIFY(LR,2),") ",$PIECE(LRB(1),U),?15,$JUSTIFY(+LRZ(6),3),?24,$JUSTIFY(+LRZ(8),3),?33,$JUSTIFY(+LRZ(10),3),?40,$$FMTE^XLFDT(LRZ(5)),?60,$$FMTE^XLFDT(LRZ(11))

           QUIT 

 +3       ;

M          READ !,"'^' TO STOP: ",LRM:DTIME

           IF '$TEST

               SET LRM=U

           IF LRM'[U

               DO H

           QUIT 

H         ;W @IOF,LRP," ",SSN(1)," Acc #: ",LRAC," Date: ",LRE,!,?15,"GRIDS",?24,"GRIDS",?32,"PRINTS",?40,"LAST DATE/TIME",?60,"LAST DATE/TIME"

 +1       ;IHS/ANMC/CLS 10/08/97

           WRITE @IOF,LRP," ",HRCN," Acc #: ",LRAC," Date: ",LRE,!,?15,"GRIDS",?24,"GRIDS",?32,"PRINTS",?40,"LAST DATE/TIME",?60,"LAST DATE/TIME"

 +2        WRITE !?5,"BLOCK ID",?14,"PREPARED",?23,"SCANNED",?33,"MADE",?44,"SCANNED",?62,"PRINTS MADE"

           QUIT 

 +3       ;

END        DO V^LRU

           QUIT