- 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 Jan 18, 2025@03:35:41 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