RADEM2.m

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