Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RADPA

RADPA.m

Go to the documentation of this file.
  1. RADPA ;HISC/GJC AISC/MJK,RMO-Look-up Rad/Nuc Med Patients ;4/17/96 11:41
  1. ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
  1. PAT S Y=-1 Q:'$D(DIC(0))
  1. N RAFLG,RAY S RAFLG=+$G(^DISV(DUZ,"^DPT(")),RAY=0
  1. S:RAFLG>0 ^DISV(DUZ,"^RADPT(")=RAFLG
  1. ; If RAOPT("REG") exists, allow addition of new patient to file 70.
  1. ; RAOPT("REG") set in entry action of RA REG
  1. I RAFLG,($D(RAOPT("REG"))),('$D(^RADPT("B",RAFLG))) D Q:RAY=-1
  1. . F D Q:RAY=-1!($D(X))
  1. .. R !,"Select Patient: ",X:DTIME
  1. .. S:'$T!(X["^")!(X']"") RAY=-1 Q:RAY=-1
  1. .. I X["?" S X="??",DIC("W")="W """"",DIC(0)="MLEZ" Q
  1. .. I X=" " D Q
  1. ... S X=$P($G(^DPT(RAFLG,0)),"^"),DIC("W")="W """"",DIC(0)="MLEZ"
  1. ... Q
  1. .. I $L(X)<3!($L(X)>30)!(X?1P.E)!(X'?1A.ANP) D
  1. ... W !?5,"Enter patient name in 'Last,First Middle' format [3-30 characters].",$C(7) K X
  1. ... Q
  1. .. E S DIC("W")="W """"",DIC(0)="MLEZ"
  1. .. Q
  1. . Q
  1. I '$D(DIC("W")),('$D(^RADPT("B",RAFLG))),($D(RAOPT("REG"))) D
  1. . S DIC(0)="AQELMZ"
  1. . Q
  1. S RAIC(0)=DIC(0),DLAYGO=70,DIC="^RADPT(",DIC("DR")=".06////"_DUZ
  1. S:'$D(DIC("A"))&(DIC(0)["A") DIC("A")="Select Patient: "
  1. W ! D ^DIC K DLAYGO I Y>0 S:RAIC(0)["L" RAPTFL=""
  1. I Y=-1,(X["?"),('$D(^RADPT("B",RAFLG))),($D(RAOPT("REG"))) G PAT
  1. ;
  1. Q I Y>0,$D(DUZ)'[0,DUZ S ^DISV(DUZ,"^DPT(")=+Y S:$D(^DIC(195.4,1,"RAD")) ^DISV(DUZ,"RT",+^("RAD"))=+Y_";DPT("
  1. K DIC("A"),DIC("DR"),RAIC Q
  1. 1 S DIC(0)="AEMQL" D PAT K DIC,RAIC Q:Y<0 S DIE="^RADPT(",DA=+Y,DR=".04;.05;1" D ^DIE K %,%Y,C,D,D0,DA,DE,DQ,DIE,DR,RAPTFL Q