- RADPA ;HISC/GJC AISC/MJK,RMO-Look-up Rad/Nuc Med Patients ;4/17/96 11:41
- ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
- PAT S Y=-1 Q:'$D(DIC(0))
- N RAFLG,RAY S RAFLG=+$G(^DISV(DUZ,"^DPT(")),RAY=0
- S:RAFLG>0 ^DISV(DUZ,"^RADPT(")=RAFLG
- ; If RAOPT("REG") exists, allow addition of new patient to file 70.
- ; RAOPT("REG") set in entry action of RA REG
- I RAFLG,($D(RAOPT("REG"))),('$D(^RADPT("B",RAFLG))) D Q:RAY=-1
- . F D Q:RAY=-1!($D(X))
- .. R !,"Select Patient: ",X:DTIME
- .. S:'$T!(X["^")!(X']"") RAY=-1 Q:RAY=-1
- .. I X["?" S X="??",DIC("W")="W """"",DIC(0)="MLEZ" Q
- .. I X=" " D Q
- ... S X=$P($G(^DPT(RAFLG,0)),"^"),DIC("W")="W """"",DIC(0)="MLEZ"
- ... Q
- .. I $L(X)<3!($L(X)>30)!(X?1P.E)!(X'?1A.ANP) D
- ... W !?5,"Enter patient name in 'Last,First Middle' format [3-30 characters].",$C(7) K X
- ... Q
- .. E S DIC("W")="W """"",DIC(0)="MLEZ"
- .. Q
- . Q
- I '$D(DIC("W")),('$D(^RADPT("B",RAFLG))),($D(RAOPT("REG"))) D
- . S DIC(0)="AQELMZ"
- . Q
- S RAIC(0)=DIC(0),DLAYGO=70,DIC="^RADPT(",DIC("DR")=".06////"_DUZ
- S:'$D(DIC("A"))&(DIC(0)["A") DIC("A")="Select Patient: "
- W ! D ^DIC K DLAYGO I Y>0 S:RAIC(0)["L" RAPTFL=""
- I Y=-1,(X["?"),('$D(^RADPT("B",RAFLG))),($D(RAOPT("REG"))) G PAT
- ;
- 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("
- K DIC("A"),DIC("DR"),RAIC Q
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRADPA 1493 printed Feb 19, 2025@00:01:06 Page 2
- 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
- PAT SET Y=-1
- if '$DATA(DIC(0))
- QUIT
- +1 NEW RAFLG,RAY
- SET RAFLG=+$GET(^DISV(DUZ,"^DPT("))
- SET RAY=0
- +2 if RAFLG>0
- SET ^DISV(DUZ,"^RADPT(")=RAFLG
- +3 ; If RAOPT("REG") exists, allow addition of new patient to file 70.
- +4 ; RAOPT("REG") set in entry action of RA REG
- +5 IF RAFLG
- IF ($DATA(RAOPT("REG")))
- IF ('$DATA(^RADPT("B",RAFLG)))
- Begin DoDot:1
- +6 FOR
- Begin DoDot:2
- +7 READ !,"Select Patient: ",X:DTIME
- +8 if '$TEST!(X["^")!(X']"")
- SET RAY=-1
- if RAY=-1
- QUIT
- +9 IF X["?"
- SET X="??"
- SET DIC("W")="W """""
- SET DIC(0)="MLEZ"
- QUIT
- +10 IF X=" "
- Begin DoDot:3
- +11 SET X=$PIECE($GET(^DPT(RAFLG,0)),"^")
- SET DIC("W")="W """""
- SET DIC(0)="MLEZ"
- +12 QUIT
- End DoDot:3
- QUIT
- +13 IF $LENGTH(X)<3!($LENGTH(X)>30)!(X?1P.E)!(X'?1A.ANP)
- Begin DoDot:3
- +14 WRITE !?5,"Enter patient name in 'Last,First Middle' format [3-30 characters].",$CHAR(7)
- KILL X
- +15 QUIT
- End DoDot:3
- +16 IF '$TEST
- SET DIC("W")="W """""
- SET DIC(0)="MLEZ"
- +17 QUIT
- End DoDot:2
- if RAY=-1!($DATA(X))
- QUIT
- +18 QUIT
- End DoDot:1
- if RAY=-1
- QUIT
- +19 IF '$DATA(DIC("W"))
- IF ('$DATA(^RADPT("B",RAFLG)))
- IF ($DATA(RAOPT("REG")))
- Begin DoDot:1
- +20 SET DIC(0)="AQELMZ"
- +21 QUIT
- End DoDot:1
- +22 SET RAIC(0)=DIC(0)
- SET DLAYGO=70
- SET DIC="^RADPT("
- SET DIC("DR")=".06////"_DUZ
- +23 if '$DATA(DIC("A"))&(DIC(0)["A")
- SET DIC("A")="Select Patient: "
- +24 WRITE !
- DO ^DIC
- KILL DLAYGO
- IF Y>0
- if RAIC(0)["L"
- SET RAPTFL=""
- +25 IF Y=-1
- IF (X["?")
- IF ('$DATA(^RADPT("B",RAFLG)))
- IF ($DATA(RAOPT("REG")))
- GOTO PAT
- +26 ;
- Q IF Y>0
- IF $DATA(DUZ)'[0
- IF DUZ
- SET ^DISV(DUZ,"^DPT(")=+Y
- if $DATA(^DIC(195.4,1,"RAD"))
- SET ^DISV(DUZ,"RT",+^("RAD"))=+Y_";DPT("
- +1 KILL DIC("A"),DIC("DR"),RAIC
- QUIT
- 1 SET DIC(0)="AEMQL"
- DO PAT
- KILL DIC,RAIC
- if Y<0
- QUIT
- SET DIE="^RADPT("
- SET DA=+Y
- SET DR=".04;.05;1"
- DO ^DIE
- KILL %,%Y,C,D,D0,DA,DE,DQ,DIE,DR,RAPTFL
- QUIT