PRSATEV ; HISC/REL-Tour Verification ;3/23/92 11:26
;;4.0;PAID;;Sep 21, 1995
S X=$G(^PRSPC(DFN,0)),DB=$P(X,"^",10),NH=$P(X,"^",50)
I DB=1 S TT=$S(NH<1:2,1:0) Q
I DB=2 S TT=$S(NH<2:3,1:0) Q
S TT=4 S PP=$P(X,"^",21) I PP="T" S:$P(X,"^",20)=9 TT=3 Q
I PP="L" S OCC=$P(X,"^",17) I "0602 0680"[$E(OCC,1,4),"23"[$E(OCC,5) S TT=3 Q
Q:PP'="M" S OCC=$P(X,"^",17),O2=$E(OCC,5,6),O1=+$E(OCC,1,4)
I O1=610 S:"71 72 80 83"[O2 TT=0 Q
I O1=605 S:"52 56"[O2 TT=0 Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSATEV 474 printed Dec 13, 2024@02:24:33 Page 2
PRSATEV ; HISC/REL-Tour Verification ;3/23/92 11:26
+1 ;;4.0;PAID;;Sep 21, 1995
+2 SET X=$GET(^PRSPC(DFN,0))
SET DB=$PIECE(X,"^",10)
SET NH=$PIECE(X,"^",50)
+3 IF DB=1
SET TT=$SELECT(NH<1:2,1:0)
QUIT
+4 IF DB=2
SET TT=$SELECT(NH<2:3,1:0)
QUIT
+5 SET TT=4
SET PP=$PIECE(X,"^",21)
IF PP="T"
if $PIECE(X,"^",20)=9
SET TT=3
QUIT
+6 IF PP="L"
SET OCC=$PIECE(X,"^",17)
IF "0602 0680"[$EXTRACT(OCC,1,4)
IF "23"[$EXTRACT(OCC,5)
SET TT=3
QUIT
+7 if PP'="M"
QUIT
SET OCC=$PIECE(X,"^",17)
SET O2=$EXTRACT(OCC,5,6)
SET O1=+$EXTRACT(OCC,1,4)
+8 IF O1=610
if "71 72 80 83"[O2
SET TT=0
QUIT
+9 IF O1=605
if "52 56"[O2
SET TT=0
QUIT
+10 QUIT
