- 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 Mar 13, 2025@21:12:06 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
