LRAPOLD ;AVAMC/REG - ENTER OLD AP ACCESSIONS ;8/12/95 08:04 ;
;;5.2;LAB SERVICE;**72,324**;Sep 27, 1994
S IOP="HOME" D ^%ZIS W @IOF,?20,"Enter old pathology records",!!
W $C(7),!,"This option skips entering accession number in the Accession Area file.",!?5,"Is this what you want " S %=2 D YN^LRU G:%'=1 END
D A^LRAPD Q:'$D(Y) S (LRB,LRC)=1 D XR^LRU
W !!,"Enter Etiology, Function, Procedure & Disease " S %=2 D YN^LRU G:%<1 END K:%=2 LRB
W !!,"Enter Special Studies " S %=2 D YN^LRU G:%<1 END K:%=2 LRC
GETP W ! K DIC D ^LRDPA G:LRDFN=-1 END D REST G GETP
REST I '$D(^LR(LRDFN,LRSS,0)) S ^LR(LRDFN,LRSS,0)="^"_LRSF_"DA^0^0"
DT W ! S %DT="AEXT",%DT(0)="-N",%DT("A")="Date (must be exact) specimen taken: " D ^%DT K %DT G:X["?" DT Q:Y<1
S LRE=Y,LRH="",LRI=9999999-Y D D^LRU S %DT("B")=Y
R W ! S %DT="AEXT",%DT(0)="-N",%DT("A")="Date (must be exact) specimen received: " D ^%DT K %DT G:X["?" R Q:Y<1 I Y<LRE W $C(7),!!,"Date received must be after date taken.",! G R
S LRAD=Y,LRF=$E(LRAD,1,3) D D^LRU S LRD=Y D A G DT
A R !!,"Enter Accession number: ",LRAN:DTIME Q:LRAN=""!(LRAN[U) I LRAN'?1N.N!($L(LRAN)>5) W $C(7),!!,"Enter up to 5 numbers",!! G A
I $D(^LR(LRXREF,LRF,LRABV,LRAN)) S X=+$O(^LR(LRXREF,LRF,LRABV,LRAN,0)) I $D(^LR(X,0)) S X=^(0) D ^LRUP W $C(7),!,"AC #",LRAN," in ",LRO(68)," for ",$E(LRF,2,3),!?5,"Patient: ",LRP," ID: ",SSN G A
I $D(^LR(LRDFN,LRSS,LRI,0)) S LRI=LRI-.00001 D FIX
L +^LR(LRDFN,LRSS) S ^LR(LRDFN,LRSS,LRI,0)=LRE,^LR(LRDFN,LRSS,0)="^"_LRSF_"DA^"_LRI_"^"_($P(^LR(LRDFN,LRSS,0),"^",4)+1) L -^LR(LRDFN,LRSS)
N LRAPOLDF
S LRAPOLDF=1
S DIE="^LR(LRDFN,LRSS,",DA=LRI,DA(1)=LRDFN,LRAC=LRABV_" "_$E(LRF,2,3)_" "_LRAN D @LRSS,^DIE
I $D(Y) W $C(7),!!,"All Prompts were not answered <ENTRY DELETED>" L +^LR(LRDFN,LRSS) K ^LR(LRDFN,LRSS,DA) D X L -^LR(LRDFN,LRSS) Q
FIX Q:'$D(^LR(LRDFN,LRSS,LRI,0)) S LRI=LRI-.00001 G FIX
X I $D(LRH),LRH>1 K ^LR(LRXR,LRH,LRDFN,LRI)
S X=^LR(LRDFN,LRSS,0),X(1)=+$O(^(0)) S ^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-1)
K ^LR(LRXREF,LRF,LRABV,LRAN,LRDFN,LRI) Q
SP S DR=".1///"_LRD_";S LRH=X;.03//"_LRD_";.02;.11////1;.06///"_LRAC_";10;.99",DR(2,63.12)=".01;S LRJ=$P(^LAB(61,X,0),U,4);S:'LRJ Y=4;2;4;S:'$D(LRB) Y=""@1"";1;1.5;3;@1;S:'$D(LRC) Y=0;5",DR(3,63.16)=".01;I '$D(LRB) S Y=0;1" Q
CY S DR=".1///"_LRD_";S LRH=X;.03//"_LRD_";.02;.11////1;.06///"_LRAC_";10;.99",DR(2,63.912)=".01;4;S:'$D(LRB) Y=""@1"";1;1.5;3;@1;S:'$D(LRC) Y=0;5",DR(3,63.916)=".01;I '$D(LRB) S Y=0;1" Q
EM S DR=".1///"_LRD_";S LRH=X;.03//"_LRD_";.02;.11////1;.06///"_LRAC_";10;.99",DR(2,63.212)=".01;4;S:'$D(LRB) Y=""@1"";1;1.5;3;@1;S:'$D(LRC) Y=0;5",DR(3,63.216)=".01;I '$D(LRB) S Y=0;1" Q
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPOLD 2683 printed Oct 16, 2024@18:08:31 Page 2
LRAPOLD ;AVAMC/REG - ENTER OLD AP ACCESSIONS ;8/12/95 08:04 ;
+1 ;;5.2;LAB SERVICE;**72,324**;Sep 27, 1994
+2 SET IOP="HOME"
DO ^%ZIS
WRITE @IOF,?20,"Enter old pathology records",!!
+3 WRITE $CHAR(7),!,"This option skips entering accession number in the Accession Area file.",!?5,"Is this what you want "
SET %=2
DO YN^LRU
if %'=1
GOTO END
+4 DO A^LRAPD
if '$DATA(Y)
QUIT
SET (LRB,LRC)=1
DO XR^LRU
+5 WRITE !!,"Enter Etiology, Function, Procedure & Disease "
SET %=2
DO YN^LRU
if %<1
GOTO END
if %=2
KILL LRB
+6 WRITE !!,"Enter Special Studies "
SET %=2
DO YN^LRU
if %<1
GOTO END
if %=2
KILL LRC
GETP WRITE !
KILL DIC
DO ^LRDPA
if LRDFN=-1
GOTO END
DO REST
GOTO GETP
REST IF '$DATA(^LR(LRDFN,LRSS,0))
SET ^LR(LRDFN,LRSS,0)="^"_LRSF_"DA^0^0"
DT WRITE !
SET %DT="AEXT"
SET %DT(0)="-N"
SET %DT("A")="Date (must be exact) specimen taken: "
DO ^%DT
KILL %DT
if X["?"
GOTO DT
if Y<1
QUIT
+1 SET LRE=Y
SET LRH=""
SET LRI=9999999-Y
DO D^LRU
SET %DT("B")=Y
R WRITE !
SET %DT="AEXT"
SET %DT(0)="-N"
SET %DT("A")="Date (must be exact) specimen received: "
DO ^%DT
KILL %DT
if X["?"
GOTO R
if Y<1
QUIT
IF Y<LRE
WRITE $CHAR(7),!!,"Date received must be after date taken.",!
GOTO R
+1 SET LRAD=Y
SET LRF=$EXTRACT(LRAD,1,3)
DO D^LRU
SET LRD=Y
DO A
GOTO DT
A READ !!,"Enter Accession number: ",LRAN:DTIME
if LRAN=""!(LRAN[U)
QUIT
IF LRAN'?1N.N!($LENGTH(LRAN)>5)
WRITE $CHAR(7),!!,"Enter up to 5 numbers",!!
GOTO A
+1 IF $DATA(^LR(LRXREF,LRF,LRABV,LRAN))
SET X=+$ORDER(^LR(LRXREF,LRF,LRABV,LRAN,0))
IF $DATA(^LR(X,0))
SET X=^(0)
DO ^LRUP
WRITE $CHAR(7),!,"AC #",LRAN," in ",LRO(68)," for ",$EXTRACT(LRF,2,3),!?5,"Patient: ",LRP," ID: ",SSN
GOTO A
+2 IF $DATA(^LR(LRDFN,LRSS,LRI,0))
SET LRI=LRI-.00001
DO FIX
+3 LOCK +^LR(LRDFN,LRSS)
SET ^LR(LRDFN,LRSS,LRI,0)=LRE
SET ^LR(LRDFN,LRSS,0)="^"_LRSF_"DA^"_LRI_"^"_($PIECE(^LR(LRDFN,LRSS,0),"^",4)+1)
LOCK -^LR(LRDFN,LRSS)
+4 NEW LRAPOLDF
+5 SET LRAPOLDF=1
+6 SET DIE="^LR(LRDFN,LRSS,"
SET DA=LRI
SET DA(1)=LRDFN
SET LRAC=LRABV_" "_$EXTRACT(LRF,2,3)_" "_LRAN
DO @LRSS
DO ^DIE
+7 IF $DATA(Y)
WRITE $CHAR(7),!!,"All Prompts were not answered <ENTRY DELETED>"
LOCK +^LR(LRDFN,LRSS)
KILL ^LR(LRDFN,LRSS,DA)
DO X
LOCK -^LR(LRDFN,LRSS)
QUIT
FIX if '$DATA(^LR(LRDFN,LRSS,LRI,0))
QUIT
SET LRI=LRI-.00001
GOTO FIX
X IF $DATA(LRH)
IF LRH>1
KILL ^LR(LRXR,LRH,LRDFN,LRI)
+1 SET X=^LR(LRDFN,LRSS,0)
SET X(1)=+$ORDER(^(0))
SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_($PIECE(X,"^",4)-1)
+2 KILL ^LR(LRXREF,LRF,LRABV,LRAN,LRDFN,LRI)
QUIT
SP SET DR=".1///"_LRD_";S LRH=X;.03//"_LRD_";.02;.11////1;.06///"_LRAC_";10;.99"
SET DR(2,63.12)=".01;S LRJ=$P(^LAB(61,X,0),U,4);S:'LRJ Y=4;2;4;S:'$D(LRB) Y=""@1"";1;1.5;3;@1;S:'$D(LRC) Y=0;5"
SET DR(3,63.16)=".01;I '$D(LRB) S Y=0;1"
QUIT
CY SET DR=".1///"_LRD_";S LRH=X;.03//"_LRD_";.02;.11////1;.06///"_LRAC_";10;.99"
SET DR(2,63.912)=".01;4;S:'$D(LRB) Y=""@1"";1;1.5;3;@1;S:'$D(LRC) Y=0;5"
SET DR(3,63.916)=".01;I '$D(LRB) S Y=0;1"
QUIT
EM SET DR=".1///"_LRD_";S LRH=X;.03//"_LRD_";.02;.11////1;.06///"_LRAC_";10;.99"
SET DR(2,63.212)=".01;4;S:'$D(LRB) Y=""@1"";1;1.5;3;@1;S:'$D(LRC) Y=0;5"
SET DR(3,63.216)=".01;I '$D(LRB) S Y=0;1"
QUIT
+1 ;
END DO V^LRU
QUIT
