| [613] | 1 | LRAPWR1 ;AVAMC/REG - STUFF CYTOPATH SCREENED SLIDES ;5/5/93 10:39
|
|---|
| 2 | ;;5.2;LAB SERVICE;;Sep 27, 1994
|
|---|
| 3 | F LR=0:0 S LR=$O(LR(LR)) Q:'LR S X=LR(LR),A=$P(X,"^"),E=$P(X,"^",2),B=$P(X,"^",3),LRT=$P(X,"^",4),LRK=$P(X,"^",5),LRX(6)=$P(X,"^",6) D A
|
|---|
| 4 | Q
|
|---|
| 5 | A I LRX(6),LRK D B Q
|
|---|
| 6 | I LRT=LRG,'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,LRR)) S LRC=LRR,LRA(1)=$S($D(^LAB(60,LRT,9,LRC,0)):$P(^(0),"^",3),1:1) W !!,"Is this a rescreen of a negative Gyn Pap Smear " S %=2 D YN^LRU Q:%<1 D:%=1 CAP,SET
|
|---|
| 7 | Q
|
|---|
| 8 | B S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)) ^(0)="^68.04PA^^"
|
|---|
| 9 | I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0)) S ^(0)=LRT_"^50^^"_DUZ_"^"_LRK,X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),^(0)=$P(X,"^",1,2)_"^"_LRT_"^"_($P(X,"^",4)+1)
|
|---|
| 10 | S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0)) ^(0)="^68.14P^^"
|
|---|
| 11 | S LRF=$S($D(^LAB(60,LRT,0)):$P(^(0),"^",19),1:"") I LRF D CAP1 D:$O(^TMP($J,0)) SET Q
|
|---|
| 12 | F LRC=0:0 S LRC=$O(^LAB(60,LRT,9.1,LRC)) Q:'LRC S LRC(3)=$P(^(LRC,0),"^",3) S:'LRC(3) LRC(3)=1 S LRA(1)=LRC(3)*LRX(6) D CAP
|
|---|
| 13 | SET S ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)="" Q
|
|---|
| 14 | ;
|
|---|
| 15 | CAP I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,LRC,0)) S ^(0)=LRC_"^"_LRA(1)_"^0^0^^"_LRK_"^"_DUZ_"^"_DUZ(2)_"^"_LRAA_"^"_LRAA_"^"_LRAA,X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0),^(0)=$P(X,"^",1,2)_"^"_LRC_"^"_($P(X,"^",4)+1) Q
|
|---|
| 16 | S X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,LRC,0),$P(X,"^",2)=$S($P(X,"^",3):LRA(1),1:$P(X,"^",2)+LRA(1)),$P(X,"^",3)=0,^(0)=X Q
|
|---|
| 17 | ;
|
|---|
| 18 | CAP1 K ^TMP($J) I '$O(^LAB(62.07,LRF,9,0)) W $C(7),!!,"No WKLD CODES to select for ",$P(^LAB(62.07,LRF,0),U)," in EXECUTE CODE file." Q
|
|---|
| 19 | I $P(^LAB(62.07,LRF,0),"^")="PAP STAIN" D CK Q:'$D(Y)
|
|---|
| 20 | F LRA=0:0 S DIC="^LAB(62.07,LRF,9,",DIC(0)="AEQM",DIC("A")="Select "_$P(^LAB(62.07,LRF,0),U)_" WKLD CODES: " D ^DIC K DIC Q:Y<1 S ^TMP($J,+Y)=LRX(6)
|
|---|
| 21 | I '$D(^TMP($J)) W $C(7),!,"No WKLD CODES selected." Q
|
|---|
| 22 | W !!,"Count WKLD CODES Selected: " F A=0:0 S A=$O(^TMP($J,A)) Q:'A S B=^(A),X=^LAM(A,0) W !,$J(B,2),?6,$P(X,U,2),?16,$P(X,U)
|
|---|
| 23 | W !,"WKLD CODES selected OK " S %=1 D YN^LRU Q:%<1 I %'=1 W !!,$C(7),"No WKLD codes selected. Try again." G CAP1
|
|---|
| 24 | F LRC=0:0 S LRC=$O(^TMP($J,LRC)) Q:'LRC S LRA(1)=^(LRC) D CAP
|
|---|
| 25 | Q
|
|---|
| 26 | CK S X=$S($D(^LR(LRDFN,LRSS,LRI,2,0)):$P(^(0),"^",4),1:0) I X'=1 S Y=1 Q
|
|---|
| 27 | S X=$O(^LR(LRDFN,LRSS,LRI,2,0)) I 'X S Y=1 Q
|
|---|
| 28 | S LRC="" F A=0:0 S A=$O(^LR(LRDFN,LRSS,LRI,2,X,2,A)) Q:'A S Y=+^(A,0),LRC=$S($D(LRF(Y)):LRF(Y),1:"") Q:LRC
|
|---|
| 29 | I 'LRC S Y=1 Q
|
|---|
| 30 | S LRA(1)=LRX(6) D CAP,SET K Y Q
|
|---|
| 31 | ;
|
|---|
| 32 | CY S X="PAP STAIN, GYN" D X^LRUWK S LRG=LRT K LRT I '$D(X) S Y=-1 Q
|
|---|
| 33 | S Y=1,LRA=$O(^LAM("E","88580.0000",0)),LRN=$O(^LAM("E","88578.0000",0)),LRR=$O(^LAM("E","88596.0000",0))
|
|---|
| 34 | I 'LRA!('LRN)!('LRR) W $C(7),!,"WKLD Codes 88580.000, 88578.000 and 88596.000 must be entered in WKLD CODE File (#64)." S Y=-1 Q
|
|---|
| 35 | F X=80013,69760,"09460","09010" S Z=$O(^LAB(61.1,"C",X,0)) S:Z LRF(Z)=$S("8001369760"[X:LRA,1:LRN) I 'Z W $C(7),!,"No entry in MORPHOLOGY File (#61.1) for SNOMED code: ",X S Y=-1
|
|---|
| 36 | Q
|
|---|
