- RADEM2 ;HISC/CAH,FPT,GJC-Display Patient Demographics (short) ;10/20/94 09:18
- ;;5.0;Radiology/Nuclear Medicine;**31**;Mar 16, 1998
- 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
- 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 D DEM^VADPT S RAGE=VADM(4) ;IHS/ITSC/CLS 02/08/2004 use IHS printable age
- ;S:$E(DT,4,7)=$E(RADOB,4,7) RAGE=RAGE+1 ; today is birthday ;IHS/ITSC/CLS 02/08/2004
- 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)
- 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
- RADEM2 ;HISC/CAH,FPT,GJC-Display Patient Demographics (short) ;10/20/94 09:18
- +1 ;;5.0;Radiology/Nuclear Medicine;**31**;Mar 16, 1998
- 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
- +1 ;IHS/ITSC/CLS 02/08/2004 use IHS printable age
- 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
- DO DEM^VADPT
- SET RAGE=VADM(4)
- +2 ;S:$E(DT,4,7)=$E(RADOB,4,7) RAGE=RAGE+1 ; today is birthday ;IHS/ITSC/CLS 02/08/2004
- +3 SET Y=RADOB
- DO D^RAUTL
- SET RADOB=Y
- +4 NEW RAVETELI
- SET RAVETELI=$$VETELI(RADFN)
- +5 SET RAVET=$PIECE(RAVETELI,"^")
- SET RAELIG=$PIECE(RAVETELI,"^",2)
- +6 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 WRITE !?2,"Other Allergies:",!?7,"'V' denotes verified allergy 'N' denotes non-verified allergy",!
- +7 SET DFN=RADFN
- DO ALLERGY^RADEM
- IF '$DATA(GMRAL)
- WRITE !?20,"** No allergies on file. **"
- GOTO ALER
- +8 FOR I=1:1
- IF '$DATA(PI(I))
- QUIT
- IF I#2
- WRITE !?2,PI(I)
- IF I#2=0
- WRITE ?40,PI(I)
- +9 ;
- 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
