- LRAPWR1 ; IHS/DIR/FJE - STUFF CYTOPATH SCREENED SLIDES 10:39 ; [ 5/5/93 ]
- ;;5.2;LR;;NOV 01, 1997
- ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- 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
- Q
- A I LRX(6),LRK D B Q
- 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
- Q
- B S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)) ^(0)="^68.04PA^^"
- 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)
- S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0)) ^(0)="^68.14P^^"
- S LRF=$S($D(^LAB(60,LRT,0)):$P(^(0),"^",19),1:"") I LRF D CAP1 D:$O(^TMP($J,0)) SET Q
- 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
- SET S ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)="" Q
- ;
- 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
- 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
- ;
- 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
- I $P(^LAB(62.07,LRF,0),"^")="PAP STAIN" D CK Q:'$D(Y)
- 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)
- I '$D(^TMP($J)) W $C(7),!,"No WKLD CODES selected." Q
- 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)
- 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
- F LRC=0:0 S LRC=$O(^TMP($J,LRC)) Q:'LRC S LRA(1)=^(LRC) D CAP
- Q
- CK S X=$S($D(^LR(LRDFN,LRSS,LRI,2,0)):$P(^(0),"^",4),1:0) I X'=1 S Y=1 Q
- S X=$O(^LR(LRDFN,LRSS,LRI,2,0)) I 'X S Y=1 Q
- 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
- I 'LRC S Y=1 Q
- S LRA(1)=LRX(6) D CAP,SET K Y Q
- ;
- CY S X="PAP STAIN, GYN" D X^LRUWK S LRG=LRT K LRT I '$D(X) S Y=-1 Q
- S Y=1,LRA=$O(^LAM("E","88580.0000",0)),LRN=$O(^LAM("E","88578.0000",0)),LRR=$O(^LAM("E","88596.0000",0))
- 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
- 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
- Q
- LRAPWR1 ; IHS/DIR/FJE - STUFF CYTOPATH SCREENED SLIDES 10:39 ; [ 5/5/93 ]
- +1 ;;5.2;LR;;NOV 01, 1997
- +2 ;
- +3 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +4 FOR LR=0:0
- SET LR=$ORDER(LR(LR))
- IF 'LR
- QUIT
- SET X=LR(LR)
- SET A=$PIECE(X,"^")
- SET E=$PIECE(X,"^",2)
- SET B=$PIECE(X,"^",3)
- SET LRT=$PIECE(X,"^",4)
- SET LRK=$PIECE(X,"^",5)
- SET LRX(6)=$PIECE(X,"^",6)
- DO A
- +5 QUIT
- A IF LRX(6)
- IF LRK
- DO B
- QUIT
- +1 IF LRT=LRG
- IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,LRR))
- SET LRC=LRR
- SET LRA(1)=$SELECT($DATA(^LAB(60,LRT,9,LRC,0)):$PIECE(^(0),"^",3),1:1)
- WRITE !!,"Is this a rescreen of a negative Gyn Pap Smear "
- SET %=2
- DO YN^LRU
- IF %<1
- QUIT
- IF %=1
- DO CAP
- DO SET
- +2 QUIT
- B IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
- SET ^(0)="^68.04PA^^"
- +1 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0))
- SET ^(0)=LRT_"^50^^"_DUZ_"^"_LRK
- SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRT_"^"_($PIECE(X,"^",4)+1)
- +2 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0))
- SET ^(0)="^68.14P^^"
- +3 SET LRF=$SELECT($DATA(^LAB(60,LRT,0)):$PIECE(^(0),"^",19),1:"")
- IF LRF
- DO CAP1
- IF $ORDER(^TMP($JOB,0))
- DO SET
- QUIT
- +4 FOR LRC=0:0
- SET LRC=$ORDER(^LAB(60,LRT,9.1,LRC))
- IF 'LRC
- QUIT
- SET LRC(3)=$PIECE(^(LRC,0),"^",3)
- IF 'LRC(3)
- SET LRC(3)=1
- SET LRA(1)=LRC(3)*LRX(6)
- DO CAP
- SET SET ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
- QUIT
- +1 ;
- CAP IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,LRC,0))
- SET ^(0)=LRC_"^"_LRA(1)_"^0^0^^"_LRK_"^"_DUZ_"^"_DUZ(2)_"^"_LRAA_"^"_LRAA_"^"_LRAA
- SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0)
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRC_"^"_($PIECE(X,"^",4)+1)
- QUIT
- +1 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,LRC,0)
- SET $PIECE(X,"^",2)=$SELECT($PIECE(X,"^",3):LRA(1),1:$PIECE(X,"^",2)+LRA(1))
- SET $PIECE(X,"^",3)=0
- SET ^(0)=X
- QUIT
- +2 ;
- CAP1 KILL ^TMP($JOB)
- IF '$ORDER(^LAB(62.07,LRF,9,0))
- WRITE $CHAR(7),!!,"No WKLD CODES to select for ",$PIECE(^LAB(62.07,LRF,0),U)," in EXECUTE CODE file."
- QUIT
- +1 IF $PIECE(^LAB(62.07,LRF,0),"^")="PAP STAIN"
- DO CK
- IF '$DATA(Y)
- QUIT
- +2 FOR LRA=0:0
- SET DIC="^LAB(62.07,LRF,9,"
- SET DIC(0)="AEQM"
- SET DIC("A")="Select "_$PIECE(^LAB(62.07,LRF,0),U)_" WKLD CODES: "
- DO ^DIC
- KILL DIC
- IF Y<1
- QUIT
- SET ^TMP($JOB,+Y)=LRX(6)
- +3 IF '$DATA(^TMP($JOB))
- WRITE $CHAR(7),!,"No WKLD CODES selected."
- QUIT
- +4 WRITE !!,"Count WKLD CODES Selected: "
- FOR A=0:0
- SET A=$ORDER(^TMP($JOB,A))
- IF 'A
- QUIT
- SET B=^(A)
- SET X=^LAM(A,0)
- WRITE !,$JUSTIFY(B,2),?6,$PIECE(X,U,2),?16,$PIECE(X,U)
- +5 WRITE !,"WKLD CODES selected OK "
- SET %=1
- DO YN^LRU
- IF %<1
- QUIT
- IF %'=1
- WRITE !!,$CHAR(7),"No WKLD codes selected. Try again."
- GOTO CAP1
- +6 FOR LRC=0:0
- SET LRC=$ORDER(^TMP($JOB,LRC))
- IF 'LRC
- QUIT
- SET LRA(1)=^(LRC)
- DO CAP
- +7 QUIT
- CK SET X=$SELECT($DATA(^LR(LRDFN,LRSS,LRI,2,0)):$PIECE(^(0),"^",4),1:0)
- IF X'=1
- SET Y=1
- QUIT
- +1 SET X=$ORDER(^LR(LRDFN,LRSS,LRI,2,0))
- IF 'X
- SET Y=1
- QUIT
- +2 SET LRC=""
- FOR A=0:0
- SET A=$ORDER(^LR(LRDFN,LRSS,LRI,2,X,2,A))
- IF 'A
- QUIT
- SET Y=+^(A,0)
- SET LRC=$SELECT($DATA(LRF(Y)):LRF(Y),1:"")
- IF LRC
- QUIT
- +3 IF 'LRC
- SET Y=1
- QUIT
- +4 SET LRA(1)=LRX(6)
- DO CAP
- DO SET
- KILL Y
- QUIT
- +5 ;
- CY SET X="PAP STAIN, GYN"
- DO X^LRUWK
- SET LRG=LRT
- KILL LRT
- IF '$DATA(X)
- SET Y=-1
- QUIT
- +1 SET Y=1
- SET LRA=$ORDER(^LAM("E","88580.0000",0))
- SET LRN=$ORDER(^LAM("E","88578.0000",0))
- SET LRR=$ORDER(^LAM("E","88596.0000",0))
- +2 IF 'LRA!('LRN)!('LRR)
- WRITE $CHAR(7),!,"WKLD Codes 88580.000, 88578.000 and 88596.000 must be entered in WKLD CODE File (#64)."
- SET Y=-1
- QUIT
- +3 FOR X=80013,69760,"09460","09010"
- SET Z=$ORDER(^LAB(61.1,"C",X,0))
- IF Z
- SET LRF(Z)=$SELECT("8001369760"[X:LRA,1:LRN)
- IF 'Z
- WRITE $CHAR(7),!,"No entry in MORPHOLOGY File (#61.1) for SNOMED code: ",X
- SET Y=-1
- +4 QUIT
