RADEM2 ;HISC/CAH,FPT,GJC-Display Patient Demographics (short) ;10/20/94 09:18
;;5.0;Radiology/Nuclear Medicine;**31,132**;Mar 16, 1998;Build 12
;ICR# Type Description
;----- ---- -------------------------------------
;1120 SUP EN6^GMRVUTL
;
PAT Q:'$D(^DPT(RADFN,0)) S Y=^(0),RANME=$P(Y,"^"),RASEX=$P(Y,"^",2),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
N RAVETELI S RAVETELI=$$VETELI(RADFN)
S RAVET=$P(RAVETELI,"^"),RAELIG=$P(RAVETELI,"^",2)
I $D(^DPT(RADFN,.1)),^(.1)]"" D ^RASERV
DIS W @IOF,!," *********** Patient Demographics ***********",!
W !?2,"Name : ",$E(RANME,1,20) W:$D(RAWARD) ?37,"Currently is an inpatient."
W !?2,"Pt ID : ",RASSN W:$D(RAWARD) ?39,"Ward/Service: ",$E(RAWARD_"/"_RASER,1,25)
W !?2,"Date of Birth: ",RADOB," (",RAGE,")" W:$D(RABED) ?39,"Bedsection : ",RABED
W !?2,"Veteran : ",RAVET,?39,"Eligibility : ",$E(RAELIG,1,25)
W !?2,"Sex : ",$S(RASEX="M":"MALE",RASEX="F":"FEMALE",1:"Unknown") I $D(^RADPT(RADFN,1)) W !?2,"Narrative : ",^(1)
;RTW Add height and weight *** BEGIN ***
D ;
.N RAHDVITL,RAHDX,DFN,GMRVSTR,X,Y
.F RAHDVITL="HT","WT" D
.. S DFN=RADFN,GMRVSTR=RAHDVITL
.. D EN6^GMRVUTL S RAHDX=$G(X)
.. W !?2,$E(RAHDVITL),"eight : ",$P(RAHDX,U,8)
.. I $P(RAHDX,U,8)]"" W $S(RAHDVITL="HT":"""",RAHDVITL="WT":" lbs",1:"")
.. S Y=$P(RAHDX,U,1) I Y>0 D D^RAUTL W " on ",Y
.. Q
. Q
;RTW Add height and weight *** END ***
W !?2,"Other Allergies:",!?7,"'V' denotes verified allergy 'N' denotes non-verified allergy",!
S DFN=RADFN D ALLERGY^RADEM I '$D(GMRAL) W !?20,"** No allergies on file. **" G ALER
F I=1:1 Q:'$D(PI(I)) W:I#2 !?2,PI(I) W:I#2=0 ?40,PI(I)
;
ALER ;
S RAPOP=0 I $D(^DPT(RADFN,.35)),$P(^(.35),"^") W !!?2,$C(7),"**** Patient has died ****",!!,"Do you want to continue? NO// " R X:DTIME S:"Nn"[X RAPOP=1
Q K RAWD,PI,RADOB,RAELIG,RAGE,RASSN,RAVET,I,VAIN,VAERR,X,Y Q:RAPOP S RACONT="" G ^RADEM1
;
RADFN S DIC(0)="AEZMQ" D ^RADPA Q:Y<0 S RADFN=+Y G PAT
;
VETELI(DFN) ; Is this patient a veteran? Does this patient have a
; primary eligibility code?
; RAELI=Primary Eligibility code <-> RAVET=Veteran (Yes/No)
N RAELI,RAVET Q:DFN'=+DFN "Unknown^Unknown"
I 'DFN!('$D(^DPT(DFN,0))#2) S (RAELI,RAVET)="Unknown"
E D
. K VAEL,VAERR D ELIG^VADPT
. S RAELI=$P($G(VAEL(1)),"^",2)
. S RAELI=$S(RAELI]"":RAELI,1:"Unknown")
. S RAVET=+$G(VAEL(4))
. S RAVET=$S(RAVET:"Yes",'RAVET:"No",1:"Unknown")
. K VAEL,VAERR
. Q
Q RAVET_"^"_RAELI
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRADEM2 2651 printed Nov 22, 2024@17:44:42 Page 2
RADEM2 ;HISC/CAH,FPT,GJC-Display Patient Demographics (short) ;10/20/94 09:18
+1 ;;5.0;Radiology/Nuclear Medicine;**31,132**;Mar 16, 1998;Build 12
+2 ;ICR# Type Description
+3 ;----- ---- -------------------------------------
+4 ;1120 SUP EN6^GMRVUTL
+5 ;
PAT if '$DATA(^DPT(RADFN,0))
QUIT
SET Y=^(0)
SET RANME=$PIECE(Y,"^")
SET RASEX=$PIECE(Y,"^",2)
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 NEW RAVETELI
SET RAVETELI=$$VETELI(RADFN)
+4 SET RAVET=$PIECE(RAVETELI,"^")
SET RAELIG=$PIECE(RAVETELI,"^",2)
+5 IF $DATA(^DPT(RADFN,.1))
IF ^(.1)]""
DO ^RASERV
DIS WRITE @IOF,!," *********** Patient Demographics ***********",!
+1 WRITE !?2,"Name : ",$EXTRACT(RANME,1,20)
if $DATA(RAWARD)
WRITE ?37,"Currently is an inpatient."
+2 WRITE !?2,"Pt ID : ",RASSN
if $DATA(RAWARD)
WRITE ?39,"Ward/Service: ",$EXTRACT(RAWARD_"/"_RASER,1,25)
+3 WRITE !?2,"Date of Birth: ",RADOB," (",RAGE,")"
if $DATA(RABED)
WRITE ?39,"Bedsection : ",RABED
+4 WRITE !?2,"Veteran : ",RAVET,?39,"Eligibility : ",$EXTRACT(RAELIG,1,25)
+5 WRITE !?2,"Sex : ",$SELECT(RASEX="M":"MALE",RASEX="F":"FEMALE",1:"Unknown")
IF $DATA(^RADPT(RADFN,1))
WRITE !?2,"Narrative : ",^(1)
+6 ;RTW Add height and weight *** BEGIN ***
+7 ;
Begin DoDot:1
+8 NEW RAHDVITL,RAHDX,DFN,GMRVSTR,X,Y
+9 FOR RAHDVITL="HT","WT"
Begin DoDot:2
+10 SET DFN=RADFN
SET GMRVSTR=RAHDVITL
+11 DO EN6^GMRVUTL
SET RAHDX=$GET(X)
+12 WRITE !?2,$EXTRACT(RAHDVITL),"eight : ",$PIECE(RAHDX,U,8)
+13 IF $PIECE(RAHDX,U,8)]""
WRITE $SELECT(RAHDVITL="HT":"""",RAHDVITL="WT":" lbs",1:"")
+14 SET Y=$PIECE(RAHDX,U,1)
IF Y>0
DO D^RAUTL
WRITE " on ",Y
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 ;RTW Add height and weight *** END ***
+18 WRITE !?2,"Other Allergies:",!?7,"'V' denotes verified allergy 'N' denotes non-verified allergy",!
+19 SET DFN=RADFN
DO ALLERGY^RADEM
IF '$DATA(GMRAL)
WRITE !?20,"** No allergies on file. **"
GOTO ALER
+20 FOR I=1:1
if '$DATA(PI(I))
QUIT
if I#2
WRITE !?2,PI(I)
if I#2=0
WRITE ?40,PI(I)
+21 ;
ALER ;
+1 SET RAPOP=0
IF $DATA(^DPT(RADFN,.35))
IF $PIECE(^(.35),"^")
WRITE !!?2,$CHAR(7),"**** Patient has died ****",!!,"Do you want to continue? NO// "
READ X:DTIME
if "Nn"[X
SET RAPOP=1
Q KILL RAWD,PI,RADOB,RAELIG,RAGE,RASSN,RAVET,I,VAIN,VAERR,X,Y
if RAPOP
QUIT
SET RACONT=""
GOTO ^RADEM1
+1 ;
RADFN SET DIC(0)="AEZMQ"
DO ^RADPA
if Y<0
QUIT
SET RADFN=+Y
GOTO PAT
+1 ;
VETELI(DFN) ; Is this patient a veteran? Does this patient have a
+1 ; primary eligibility code?
+2 ; RAELI=Primary Eligibility code <-> RAVET=Veteran (Yes/No)
+3 NEW RAELI,RAVET
if DFN'=+DFN
QUIT "Unknown^Unknown"
+4 IF 'DFN!('$DATA(^DPT(DFN,0))#2)
SET (RAELI,RAVET)="Unknown"
+5 IF '$TEST
Begin DoDot:1
+6 KILL VAEL,VAERR
DO ELIG^VADPT
+7 SET RAELI=$PIECE($GET(VAEL(1)),"^",2)
+8 SET RAELI=$SELECT(RAELI]"":RAELI,1:"Unknown")
+9 SET RAVET=+$GET(VAEL(4))
+10 SET RAVET=$SELECT(RAVET:"Yes",'RAVET:"No",1:"Unknown")
+11 KILL VAEL,VAERR
+12 QUIT
End DoDot:1
+13 QUIT RAVET_"^"_RAELI
