RADEM ;HISC/CAH AISC/MJK,RMO,DMK-Display Patient Demographics ;1/22/97 11:10
;;5.0;Radiology/Nuclear Medicine;**31**;Mar 16, 1998
PAT G Q:'$D(^DPT(RADFN,0)) S Y=^(0),RANME=$P(Y,"^"),RASEX=$S($P(Y,"^",2)="M":"MALE",$P(Y,"^",2)="F":"FEMALE",1:"Unknown"),RASSN=$$SSN^RAUTL,RADOB=$P(Y,"^",3),X1=DT,X2=RADOB D ^%DTC S RAGE=X\365.25
S:$E(DT,4,7)=$E(RADOB,4,7) RAGE=RAGE+1 ;today is birthday
S Y=RADOB D D^RAUTL S RADOB=Y
; obtain patient address data
K VAERR,RAPA S DFN=RADFN,VAROOT="RAPA" D ADD^VADPT K VAROOT
I VAERR D ; Error, invalid DFN or corrupt ^DPT(DFN,0) node
. F RAI=1:1:3 S RAPA(RAI)="Unknown"
. S RATWN="Unknown",RAPA(8)="Unknown"
. Q
I 'VAERR D
. S RATWN=$G(RAPA(4))_", "_$P($G(^DIC(5,+$G(RAPA(5)),0)),U,2)_" "_$G(RAPA(6))
. Q
N RAVETELI S RAVETELI=$$VETELI^RADEM2(RADFN)
S RAVET=$P(RAVETELI,"^"),RAELIG=$E($P(RAVETELI,"^",2),1,25)
S (RAMED,RAUSAL)="Unknown" S Y=$$ORCHK^GMRAOR(RADFN,"CM") S RAMED=$S(Y=1:"Yes",Y=0:"No",1:RAMED)
I $D(^RADPT(RADFN,0)) S Y=^(0) D
. S RAUSAL=$P($P(^DD(70,.04,0),$P(Y,"^",4)_":",2),";")
. S:RAUSAL']"" RAUSAL="Unknown"
. Q
I $D(^DPT(RADFN,.1)),^(.1)]"" D ^RASERV
DIS D HOME^%ZIS W @IOF," *********** Patient Demographics ***********",!
W !?2,"Name : ",$E(RANME,1,20),?40,"Address: ",?50,$G(RAPA(1))
W !?2,"Pt ID : ",RASSN,?38,$S($G(RAPA(9))]"":"(temporary)",1:""),?50,$G(RAPA(2))
W !?2,"Date of Birth: ",RADOB,?50,$G(RAPA(3))
W !?2,"Age : ",RAGE,?50,$G(RATWN)
W !?2,"Veteran : ",RAVET W:$D(RAWARD) ?40,"Currently is an inpatient."
W !?2,"Eligibility : ",RAELIG W:$D(RAWARD) ?42,"Ward : ",RAWARD
W !?2,"Exam Category: ",RAUSAL W:$D(RASER) ?42,"Service : ",RASER
W !?2,"Sex : ",RASEX W:$D(RABED) ?42,"Bedsection : ",RABED
W !?2,"Phone Number : ",$G(RAPA(8))
I $D(^RADPT(RADFN,1)) W !?2,"Narrative : ",^(1)
W !!?2,"Contrast Medium Reaction: ",RAMED
W !,?2,"Other Allergies:",!?7,"'V' denotes verified allergy 'N' denotes non-verified allergy",!
S DFN=RADFN D ALLERGY I '$D(GMRAL) W !?20,"** No allergies on file **" G Q
S RAXIT=0 F I=1:1 Q:'$D(PI(I))!RAXIT D
. W:I#2 !?2,PI(I) W:I#2=0 ?40,PI(I)
. I $E(IOST,1,2)="C-",($Y>(IOSL-7)),$D(PI(I+1))#2,(I#2=0) D
.. N DIR S DIR(0)="E" D ^DIR S RAXIT=$S(Y'>0:1,1:0) Q:RAXIT
.. W @IOF,!,?2,"Other Allergies:",!?7,"'V' denotes verified allergy 'N' denotes non-verified allergy",!
.. Q
. Q
I RAXIT G Q^RADEM1
Q I $D(^DPT(RADFN,.35)),$P(^(.35),"^") W !!?2,$C(7),"**** Patient has died ****" H 3
K %,%H,POP,RATWN,RASEX,RAWD,PI,RADOB,RAELIG,RAGE,RAI,RAMED,RANME,RAPA
K RASER,RASSN,RAUSAL,RAVET,RAWARD,ST,I,VAIN,VAERR,RABED,GMRAL G ^RADEM1
;
RADFN S DIC="^DPT(",DIC(0)="AEMQ" D ^DIC K DIC Q:Y<0 S RADFN=+Y G PAT
;
ALLERGY ;get allergies DFN must be defined
;returns PI(CNT)
S X="GMRADPT" X ^%ZOSF("TEST") Q:'$T
N I,CNT
Q:'$D(DFN) D ^GMRADPT Q:'$D(GMRAL)
S (I,CNT)=0
F S I=$O(GMRAL(I)) Q:'I I $P(GMRAL(I),"^",2)]"" S CNT=CNT+1,PI(CNT)=$E($P(GMRAL(I),"^",2),1,35) D
.S PI(CNT)=PI(CNT)_"("_$S($P(GMRAL(I),"^",4)=1:"V",1:"N")_")" Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRADEM 3092 printed Sep 23, 2025@20:10:42 Page 2
RADEM ;HISC/CAH AISC/MJK,RMO,DMK-Display Patient Demographics ;1/22/97 11:10
+1 ;;5.0;Radiology/Nuclear Medicine;**31**;Mar 16, 1998
PAT if '$DATA(^DPT(RADFN,0))
GOTO Q
SET Y=^(0)
SET RANME=$PIECE(Y,"^")
SET RASEX=$SELECT($PIECE(Y,"^",2)="M":"MALE",$PIECE(Y,"^",2)="F":"FEMALE",1:"Unknown")
SET RASSN=$$SSN^RAUTL
SET RADOB=$PIECE(Y,"^",3)
SET X1=DT
SET X2=RADOB
DO ^%DTC
SET RAGE=X\365.25
+1 ;today is birthday
if $EXTRACT(DT,4,7)=$EXTRACT(RADOB,4,7)
SET RAGE=RAGE+1
+2 SET Y=RADOB
DO D^RAUTL
SET RADOB=Y
+3 ; obtain patient address data
+4 KILL VAERR,RAPA
SET DFN=RADFN
SET VAROOT="RAPA"
DO ADD^VADPT
KILL VAROOT
+5 ; Error, invalid DFN or corrupt ^DPT(DFN,0) node
IF VAERR
Begin DoDot:1
+6 FOR RAI=1:1:3
SET RAPA(RAI)="Unknown"
+7 SET RATWN="Unknown"
SET RAPA(8)="Unknown"
+8 QUIT
End DoDot:1
+9 IF 'VAERR
Begin DoDot:1
+10 SET RATWN=$GET(RAPA(4))_", "_$PIECE($GET(^DIC(5,+$GET(RAPA(5)),0)),U,2)_" "_$GET(RAPA(6))
+11 QUIT
End DoDot:1
+12 NEW RAVETELI
SET RAVETELI=$$VETELI^RADEM2(RADFN)
+13 SET RAVET=$PIECE(RAVETELI,"^")
SET RAELIG=$EXTRACT($PIECE(RAVETELI,"^",2),1,25)
+14 SET (RAMED,RAUSAL)="Unknown"
SET Y=$$ORCHK^GMRAOR(RADFN,"CM")
SET RAMED=$SELECT(Y=1:"Yes",Y=0:"No",1:RAMED)
+15 IF $DATA(^RADPT(RADFN,0))
SET Y=^(0)
Begin DoDot:1
+16 SET RAUSAL=$PIECE($PIECE(^DD(70,.04,0),$PIECE(Y,"^",4)_":",2),";")
+17 if RAUSAL']""
SET RAUSAL="Unknown"
+18 QUIT
End DoDot:1
+19 IF $DATA(^DPT(RADFN,.1))
IF ^(.1)]""
DO ^RASERV
DIS DO HOME^%ZIS
WRITE @IOF," *********** Patient Demographics ***********",!
+1 WRITE !?2,"Name : ",$EXTRACT(RANME,1,20),?40,"Address: ",?50,$GET(RAPA(1))
+2 WRITE !?2,"Pt ID : ",RASSN,?38,$SELECT($GET(RAPA(9))]"":"(temporary)",1:""),?50,$GET(RAPA(2))
+3 WRITE !?2,"Date of Birth: ",RADOB,?50,$GET(RAPA(3))
+4 WRITE !?2,"Age : ",RAGE,?50,$GET(RATWN)
+5 WRITE !?2,"Veteran : ",RAVET
if $DATA(RAWARD)
WRITE ?40,"Currently is an inpatient."
+6 WRITE !?2,"Eligibility : ",RAELIG
if $DATA(RAWARD)
WRITE ?42,"Ward : ",RAWARD
+7 WRITE !?2,"Exam Category: ",RAUSAL
if $DATA(RASER)
WRITE ?42,"Service : ",RASER
+8 WRITE !?2,"Sex : ",RASEX
if $DATA(RABED)
WRITE ?42,"Bedsection : ",RABED
+9 WRITE !?2,"Phone Number : ",$GET(RAPA(8))
+10 IF $DATA(^RADPT(RADFN,1))
WRITE !?2,"Narrative : ",^(1)
+11 WRITE !!?2,"Contrast Medium Reaction: ",RAMED
+12 WRITE !,?2,"Other Allergies:",!?7,"'V' denotes verified allergy 'N' denotes non-verified allergy",!
+13 SET DFN=RADFN
DO ALLERGY
IF '$DATA(GMRAL)
WRITE !?20,"** No allergies on file **"
GOTO Q
+14 SET RAXIT=0
FOR I=1:1
if '$DATA(PI(I))!RAXIT
QUIT
Begin DoDot:1
+15 if I#2
WRITE !?2,PI(I)
if I#2=0
WRITE ?40,PI(I)
+16 IF $EXTRACT(IOST,1,2)="C-"
IF ($Y>(IOSL-7))
IF $DATA(PI(I+1))#2
IF (I#2=0)
Begin DoDot:2
+17 NEW DIR
SET DIR(0)="E"
DO ^DIR
SET RAXIT=$SELECT(Y'>0:1,1:0)
if RAXIT
QUIT
+18 WRITE @IOF,!,?2,"Other Allergies:",!?7,"'V' denotes verified allergy 'N' denotes non-verified allergy",!
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 IF RAXIT
GOTO Q^RADEM1
Q IF $DATA(^DPT(RADFN,.35))
IF $PIECE(^(.35),"^")
WRITE !!?2,$CHAR(7),"**** Patient has died ****"
HANG 3
+1 KILL %,%H,POP,RATWN,RASEX,RAWD,PI,RADOB,RAELIG,RAGE,RAI,RAMED,RANME,RAPA
+2 KILL RASER,RASSN,RAUSAL,RAVET,RAWARD,ST,I,VAIN,VAERR,RABED,GMRAL
GOTO ^RADEM1
+3 ;
RADFN SET DIC="^DPT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
if Y<0
QUIT
SET RADFN=+Y
GOTO PAT
+1 ;
ALLERGY ;get allergies DFN must be defined
+1 ;returns PI(CNT)
+2 SET X="GMRADPT"
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT
+3 NEW I,CNT
+4 if '$DATA(DFN)
QUIT
DO ^GMRADPT
if '$DATA(GMRAL)
QUIT
+5 SET (I,CNT)=0
+6 FOR
SET I=$ORDER(GMRAL(I))
if 'I
QUIT
IF $PIECE(GMRAL(I),"^",2)]""
SET CNT=CNT+1
SET PI(CNT)=$EXTRACT($PIECE(GMRAL(I),"^",2),1,35)
Begin DoDot:1
+7 SET PI(CNT)=PI(CNT)_"("_$SELECT($PIECE(GMRAL(I),"^",4)=1:"V",1:"N")_")"
QUIT
End DoDot:1
+8 QUIT
