RAPROQ.m

RAPROQ ;HISC/CAH,FPT,GJC AISC/MJK-Exam Profile (quick) ;9/12/94  11:21

 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998

PAT S DIC(0)="AEMQ" D ^RADPA G Q:Y<0 S RADFN=+Y D RT G Q:$D(RTESC) S RAHEAD="**** Registered Exams Quick Profile ****" S RAF1=1 D ^RAPTLU G Q:X="^" G PAT:'$D(RADUP)

 D Q1 F RAK=0:0 S RAK=$O(RADUP(RAK)) Q:RAK'>0  S Y=^TMP($J,"RAEX",RAK) D SET,^RAPROD

Q K RAF1,RADUP,RAK,RAJ,^TMP($J,"RAEX"),X,Y,DIC,N,RAI,RAPAR,RASEL

 K RACNI,RACN,RADATE,RADFN,RADTE,RADTI,RANME,RAPRC,RARPT,RASSN,RAST

 ;

Q1 K RTFL,RTESC,RAF1,RAHEAD,RAPROC Q

SET F RAJ=1:1:11 S @$P("RADFN^RADTI^RACNI^RANME^RASSN^RADATE^RADTE^RACN^RAPRC^RARPT^RAST","^",RAJ)=$P(Y,"^",RAJ)

 S Y(0)=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) Q

 ;

RT Q:'$D(^DIC(195.4,1,"RAD"))  S Y=+^("RAD") S:$D(RTAPL) RARTAPL=+RTAPL D APL1^RTPSET:$S('$D(RTAPL):1,1:Y'=+RTAPL)

 I $D(RTAPL) S RTE=RADFN_";DPT(",RTDC("S")="I $P(^(0),U,4)="_+RTAPL D ^RTUTL2 S RTFL="" K RT1,RTC,RTDC,RTE,RTAPL,RTSYS

 I $D(RARTAPL) S Y=RARTAPL D APL1^RTPSET K RARTAPL

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---RAPROQ   1008     printed  Apr 09, 2024@21:34:53                                                                                                                                                                                                      Page 2

RAPROQ    ;HISC/CAH,FPT,GJC AISC/MJK-Exam Profile (quick) ;9/12/94  11:21

 +1       ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998

PAT        SET DIC(0)="AEMQ"

           DO ^RADPA

           if Y<0

               GOTO Q

           SET RADFN=+Y

           DO RT

           if $DATA(RTESC)

               GOTO Q

           SET RAHEAD="**** Registered Exams Quick Profile ****"

           SET RAF1=1

           DO ^RAPTLU

           if X="^"

               GOTO Q

           if '$DATA(RADUP)

               GOTO PAT

 +1        DO Q1

           FOR RAK=0:0

               SET RAK=$ORDER(RADUP(RAK))

               if RAK'>0

                   QUIT 

               SET Y=^TMP($JOB,"RAEX",RAK)

               DO SET

               DO ^RAPROD

Q          KILL RAF1,RADUP,RAK,RAJ,^TMP($JOB,"RAEX"),X,Y,DIC,N,RAI,RAPAR,RASEL

 +1        KILL RACNI,RACN,RADATE,RADFN,RADTE,RADTI,RANME,RAPRC,RARPT,RASSN,RAST

 +2       ;

Q1         KILL RTFL,RTESC,RAF1,RAHEAD,RAPROC

           QUIT 

SET        FOR RAJ=1:1:11

               SET @$PIECE("RADFN^RADTI^RACNI^RANME^RASSN^RADATE^RADTE^RACN^RAPRC^RARPT^RAST","^",RAJ)=$PIECE(Y,"^",RAJ)

 +1        SET Y(0)=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)

           QUIT 

 +2       ;

RT         if '$DATA(^DIC(195.4,1,"RAD"))

               QUIT 

           SET Y=+^("RAD")

           if $DATA(RTAPL)

               SET RARTAPL=+RTAPL

           if $SELECT('$DATA(RTAPL):1,1:Y'=+RTAPL)

               DO APL1^RTPSET

 +1        IF $DATA(RTAPL)

               SET RTE=RADFN_";DPT("

               SET RTDC("S")="I $P(^(0),U,4)="_+RTAPL

               DO ^RTUTL2

               SET RTFL=""

               KILL RT1,RTC,RTDC,RTE,RTAPL,RTSYS

 +2        IF $DATA(RARTAPL)

               SET Y=RARTAPL

               DO APL1^RTPSET

               KILL RARTAPL

 +3        QUIT