PRSATEV.m

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 ---PRSATEV   474     printed  Mar 13, 2025@21:29:36                                                                                                                                                                                                      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