source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAPROQ.m@ 1806

Last change on this file since 1806 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 993 bytes
Line 
1RAPROQ ;HISC/CAH,FPT,GJC AISC/MJK-Exam Profile (quick) ;9/12/94 11:21
2 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
3PAT 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)
4 D Q1 F RAK=0:0 S RAK=$O(RADUP(RAK)) Q:RAK'>0 S Y=^TMP($J,"RAEX",RAK) D SET,^RAPROD
5Q K RAF1,RADUP,RAK,RAJ,^TMP($J,"RAEX"),X,Y,DIC,N,RAI,RAPAR,RASEL
6 K RACNI,RACN,RADATE,RADFN,RADTE,RADTI,RANME,RAPRC,RARPT,RASSN,RAST
7 ;
8Q1 K RTFL,RTESC,RAF1,RAHEAD,RAPROC Q
9SET F RAJ=1:1:11 S @$P("RADFN^RADTI^RACNI^RANME^RASSN^RADATE^RADTE^RACN^RAPRC^RARPT^RAST","^",RAJ)=$P(Y,"^",RAJ)
10 S Y(0)=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) Q
11 ;
12RT 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)
13 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
14 I $D(RARTAPL) S Y=RARTAPL D APL1^RTPSET K RARTAPL
15 Q
Note: See TracBrowser for help on using the repository browser.