RADEM1.m

RADEM1 ;HISC/GJC-Display Patient Demographics ; May 21, 2020@10:38:36

 ;;5.0;Radiology/Nuclear Medicine;**45,47,169**;Mar 16, 1998;Build 2

EXAM D HDR S RAXIT=0

 S X1=DT,X2=-7 D C^%DTC S RACHKDT=X,X1=DT,X2=-3 D C^%DTC S RACHKDT1=X

 S (RADTE,RASEQ)=0 F RADTI=0:0 Q:(RASEQ>4)&(RADTE<RACHKDT)!RAXIT  S RADTI=$O(^RADPT(RADFN,"DT",RADTI)) Q:RADTI'>0!RAXIT  I $D(^(RADTI,0)) S Y=^(0),RALOC=+$P(Y,"^",4),(RADTE,Y)=+Y Q:(RASEQ>4)&(RADTE<RACHKDT)  D D^RAUTL S RADATE=Y D RACN

 I $G(RAXIT) G Q

 D ORDER ;Check for outstanding orders

 W:'RASEQ !!?5,"No registered exams filed for this patient.",!

 W:$D(RABARFL) !?2,"  *Exam with Barium performed in last 7 days."

 W:$D(RAORFL) !?2," **Oral Cholecystographic medium used in last 7 days."

 I $D(RACNFL) D

 .N DIWF,DIWL,DIWR,DIWT,X K ^UTILITY($J,"W")

 .S:'$D(RAZDFN)#2 X="***Exam with contrast media performed in last 3 days."

 .S:$D(RAZDFN)#2 X="***Exam with "_$$CM(RAZDFN,RAZDTI,RAZCNI)_" performed in last 3 days."

 .S DIWL=3,DIWF="C60" D ^DIWP,^DIWW ;UTILITY($J,"W") killed in DIWW

 .Q

 I '$D(RACONT),('+$G(RAXIT)) R !!,"Press <RETURN> key to continue.",X:DTIME

Q K %,%H,DIC,POP,RACNFL,RAORFL,RACODE,RACONT,RABAR,RABARFL,RACHKDT,RACHKDT1,RACN,RACNI,RADATE,RADTE,RADTI,RAPR1,RAPRI,RASEQ,RAST,RASTI,RAXIT,RAZDFN,RAZDTI,RAZCNI Q

 ;

RACN S RALOC=$S($D(^RA(79.1,RALOC,0)):$P(^(0),"^"),1:"") S RALOC=$S($D(^SC(+RALOC,0)):$P(^(0),"^"),1:"Unknown")

 F RACNI=0:0 Q:(RASEQ>4)&(RADTE<RACHKDT)!RAXIT  S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0!RAXIT  I $D(^(RACNI,0)) S Y=^(0) D PRT

 Q

 ;

PRT N RAESITY,RAITYPE

 S RAPRI=+$P(Y,"^",2),RAPR1=99 S:$D(^RAMIS(71,RAPRI,0)) RAPR1=$P(^(0),"^") S RABAR=0

 I $P(Y,U,10)="Y" D

 .I RADTE'<RACHKDT,($O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM","B",""))="B") S (RABAR,RABARFL)=1,RACODE="  *"

 .I RADTE'<RACHKDT,(+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM","B","C",0))>0) S (RABAR,RAORFL)=1,RACODE=" **"

 .I RADTE'<RACHKDT1 D

 ..S (RABAR,RACNFL)=1,RACODE="***"

 ..I +$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",0)) S RAZDFN=RADFN,RAZDTI=RADTI,RAZCNI=RACNI

 ..Q

 .Q

 S RASTI=+$P(Y,"^",3)

 S RAST=$S($D(^RA(72,RASTI,0)):$P(^(0),"^"),1:"Unknown")

 S RAESITY=+$P($G(^RA(72,RASTI,0)),U,7)

 S RAITYPE=$P($G(^RA(79.2,RAESITY,0)),U)

 S RAITYPE=$S(RAITYPE]"":RAITYPE,1:"Unknown")

 S RACN=$S($D(^RA(72,"AA",RAITYPE,9,RASTI)):"",1:+Y)

 ; flag if print set and if lowest case of set

 N RAPRTSET,RAMEMLOW,RADISP D EN1^RAUTL20

 S RADISP=$S(RAMEMLOW&(RAPRTSET):"+",RAPRTSET:".",1:" ")

 N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)

 S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN)

 I $$USESSAN^RAHLRU1() S RASEQ=RASEQ+1 W:RASEQ<6!(RABAR) !,RACNDSP," ",RADISP,$S(RABAR:RACODE,1:""),?18,$E(RAPR1,1,28),?47,$$DATEPRT^RAHLRU1(RADTE),?56,$E(RAST,1,12),?68,$E(RALOC,1,12)

 I '$$USESSAN^RAHLRU1() S RASEQ=RASEQ+1 W:RASEQ<6!(RABAR) !,RACN,?6,RADISP,?7,$S(RABAR:RACODE,1:""),?10,$E(RAPR1,1,28),?39,$E(RADATE,1,11),?51,$E(RAST,1,12),?67,$E(RALOC,1,12)

 I $E(IOST,1,2)="C-",($Y>(IOSL-4)) D

 . N DIR S DIR(0)="E" D ^DIR S RAXIT=$S(Y'>0:1,1:0)

 . I 'RAXIT W @IOF D HDR

 . Q

 Q

ORDER ; Check for pat rad orders before registering a patient in rad

 ; Created by GJC@1/3/94

 N RALP,RA751,DIROUT,DIRUT,DTOUT,DUOUT S (RALP,RAXIT)=0

 F  S RALP=$O(^RAO(75.1,"B",RADFN,RALP)) Q:RALP'>0!(RAXIT)  D

 . ;check if the order for this patient has been registered

 . Q:$D(^RADPT("AO",RALP,RADFN))\10

 . ;if the order status is discontinued (1), complete (2) or

 . ;cancelled (13) quit gjc RA5P169

 . S RA751(0)=$G(^RAO(75.1,RALP,0)),RA751(5)=+$P(RA751(0),U,5)

 . I RA751(5)<3!(RA751(5)=13) QUIT

 . S RA751(2)=$P(RA751(0),U,2),RA751(16)=$P(RA751(0),U,16)

 . S RA751(20)=$P(RA751(0),U,20)

 . S Y=RA751(2),C=$P($G(^DD(75.1,2,0)),U,2) D:Y]"" Y^DIQ S RA751(2)=Y

 . S Y=RA751(20),C=$P($G(^DD(75.1,20,0)),U,2) D:Y]"" Y^DIQ S RA751(20)=Y

 . I $$USESSAN^RAHLRU1() W !?18,$E(RA751(2),1,28),?56,"Ord "

 . I '$$USESSAN^RAHLRU1() W !?10,$E(RA751(2),1,28),?51,"Ord "

 . W $S(RA751(16)]"":$$FMTE^XLFDT(RA751(16),"2D"),1:"")

 . ; prints 'SUBMIT REQUEST TO' data

 . I $$USESSAN^RAHLRU1() W ?68,$E(RA751(20),1,12)

 . I '$$USESSAN^RAHLRU1() W ?67,$E(RA751(20),1,12)

 . I $E(IOST,1,2)="C-",($Y>(IOSL-4)) D

 .. K DIR S DIR(0)="E" D ^DIR K DIR S:'+Y RAXIT=1

 .. I 'RAXIT W @IOF D HDR

 .. Q

 . Q

 Q

HDR ; Header

 ; Created by GJC@1/3/94 ; modified for SSAN by RTK 3/19/09

 ; The variable: RAOPT("ORDEREXAM") is defined in the entry action of

 ; the option RA ORDEREXAM.  It is subsequently kill in the exit action

 ; of the option.

 D HOME^%ZIS W:$D(RAOPT("ORDEREXAM"))#2 @IOF

 I $$USESSAN^RAHLRU1() W !!,"Case #",?18,"Last 5 Procedures/New Orders",?47,"Exam Dt",?56,"Exam Status",?68,"Imaging Loc."

 I $$USESSAN^RAHLRU1() W !,"----------------",?18,"----------------------------",?47,"--------",?56,"-----------",?68,"------------"

 I '$$USESSAN^RAHLRU1() W !!,"Case #",?10,"Last 5 Procedures/New Orders",?39,"Exam Date",?51,"Status of Exam",?67,"Imaging Loc."

 I '$$USESSAN^RAHLRU1() W !,"------",?10,"----------------------------",?39,"---------",?51,"--------------",?67,"------------"

 Q

 ;

CM(RADFN,RADTI,RACNI) ;Return the contrast media used while performing an

 ;exam.

 ;Input: RADFN=patient DFN

 ;       RADTI=inverse date/time of exam

 ;       RACNI=IEN of an individual case

 ;Return: contrast media used with exam delimited by ', '.

 N I,X S X="",I=0

 F  S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",I)) Q:'I  D

 .S I(0)=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",I,0),U)

 .S X=X_$$EXTERNAL^DILFD(70.3225,.01,"",I(0))_", "

 .Q

 I $L(X,", ")'>2 S X=$P(X,", ")

 E  S X=$P(X,", ",1,($L(X,", ")-1))

 Q X

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---RADEM1   5636     printed  Feb 19, 2025@00:00:58                                                                                                                                                                                                      Page 2

RADEM1    ;HISC/GJC-Display Patient Demographics ; May 21, 2020@10:38:36

 +1       ;;5.0;Radiology/Nuclear Medicine;**45,47,169**;Mar 16, 1998;Build 2

EXAM       DO HDR

           SET RAXIT=0

 +1        SET X1=DT

           SET X2=-7

           DO C^%DTC

           SET RACHKDT=X

           SET X1=DT

           SET X2=-3

           DO C^%DTC

           SET RACHKDT1=X

 +2        SET (RADTE,RASEQ)=0

           FOR RADTI=0:0

               if (RASEQ>4)&(RADTE<RACHKDT)!RAXIT

                   QUIT 

               SET RADTI=$ORDER(^RADPT(RADFN,"DT",RADTI))

               if RADTI'>0!RAXIT

                   QUIT 

               IF $DATA(^(RADTI,0))

                   SET Y=^(0)

                   SET RALOC=+$PIECE(Y,"^",4)

                   SET (RADTE,Y)=+Y

                   if (RASEQ>4)&(RADTE<RACHKDT)

                       QUIT 

                   DO D^RAUTL

                   SET RADATE=Y

                   DO RACN

 +3        IF $GET(RAXIT)

               GOTO Q

 +4       ;Check for outstanding orders

           DO ORDER

 +5        if 'RASEQ

               WRITE !!?5,"No registered exams filed for this patient.",!

 +6        if $DATA(RABARFL)

               WRITE !?2,"  *Exam with Barium performed in last 7 days."

 +7        if $DATA(RAORFL)

               WRITE !?2," **Oral Cholecystographic medium used in last 7 days."

 +8        IF $DATA(RACNFL)

               Begin DoDot:1

 +9                NEW DIWF,DIWL,DIWR,DIWT,X

                   KILL ^UTILITY($JOB,"W")

 +10               if '$DATA(RAZDFN)#2

                       SET X="***Exam with contrast media performed in last 3 days."

 +11               if $DATA(RAZDFN)#2

                       SET X="***Exam with "_$$CM(RAZDFN,RAZDTI,RAZCNI)_" performed in last 3 days."

 +12      ;UTILITY($J,"W") killed in DIWW

                   SET DIWL=3

                   SET DIWF="C60"

                   DO ^DIWP

                   DO ^DIWW

 +13               QUIT 

               End DoDot:1

 +14       IF '$DATA(RACONT)

               IF ('+$GET(RAXIT))

                   READ !!,"Press <RETURN> key to continue.",X:DTIME

Q          KILL %,%H,DIC,POP,RACNFL,RAORFL,RACODE,RACONT,RABAR,RABARFL,RACHKDT,RACHKDT1,RACN,RACNI,RADATE,RADTE,RADTI,RAPR1,RAPRI,RASEQ,RAST,RASTI,RAXIT,RAZDFN,RAZDTI,RAZCNI

           QUIT 

 +1       ;

RACN       SET RALOC=$SELECT($DATA(^RA(79.1,RALOC,0)):$PIECE(^(0),"^"),1:"")

           SET RALOC=$SELECT($DATA(^SC(+RALOC,0)):$PIECE(^(0),"^"),1:"Unknown")

 +1        FOR RACNI=0:0

               if (RASEQ>4)&(RADTE<RACHKDT)!RAXIT

                   QUIT 

               SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))

               if RACNI'>0!RAXIT

                   QUIT 

               IF $DATA(^(RACNI,0))

                   SET Y=^(0)

                   DO PRT

 +2        QUIT 

 +3       ;

PRT        NEW RAESITY,RAITYPE

 +1        SET RAPRI=+$PIECE(Y,"^",2)

           SET RAPR1=99

           if $DATA(^RAMIS(71,RAPRI,0))

               SET RAPR1=$PIECE(^(0),"^")

           SET RABAR=0

 +2        IF $PIECE(Y,U,10)="Y"

               Begin DoDot:1

 +3                IF RADTE'<RACHKDT

                       IF ($ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM","B",""))="B")

                           SET (RABAR,RABARFL)=1

                           SET RACODE="  *"

 +4                IF RADTE'<RACHKDT

                       IF (+$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM","B","C",0))>0)

                           SET (RABAR,RAORFL)=1

                           SET RACODE=" **"

 +5                IF RADTE'<RACHKDT1

                       Begin DoDot:2

 +6                        SET (RABAR,RACNFL)=1

                           SET RACODE="***"

 +7                        IF +$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",0))

                               SET RAZDFN=RADFN

                               SET RAZDTI=RADTI

                               SET RAZCNI=RACNI

 +8                        QUIT 

                       End DoDot:2

 +9                QUIT 

               End DoDot:1

 +10       SET RASTI=+$PIECE(Y,"^",3)

 +11       SET RAST=$SELECT($DATA(^RA(72,RASTI,0)):$PIECE(^(0),"^"),1:"Unknown")

 +12       SET RAESITY=+$PIECE($GET(^RA(72,RASTI,0)),U,7)

 +13       SET RAITYPE=$PIECE($GET(^RA(79.2,RAESITY,0)),U)

 +14       SET RAITYPE=$SELECT(RAITYPE]"":RAITYPE,1:"Unknown")

 +15       SET RACN=$SELECT($DATA(^RA(72,"AA",RAITYPE,9,RASTI)):"",1:+Y)

 +16      ; flag if print set and if lowest case of set

 +17       NEW RAPRTSET,RAMEMLOW,RADISP

           DO EN1^RAUTL20

 +18       SET RADISP=$SELECT(RAMEMLOW&(RAPRTSET):"+",RAPRTSET:".",1:" ")

 +19       NEW RASSAN,RACNDSP

           SET RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)

 +20       SET RACNDSP=$SELECT((RASSAN'=""):RASSAN,1:RACN)

 +21       IF $$USESSAN^RAHLRU1()

               SET RASEQ=RASEQ+1

               if RASEQ<6!(RABAR)

                   WRITE !,RACNDSP," ",RADISP,$SELECT(RABAR:RACODE,1:""),?18,$EXTRACT(RAPR1,1,28),?47,$$DATEPRT^RAHLRU1(RADTE),?56,$EXTRACT(RAST,1,12),?68,$EXTRACT(RALOC,1,12)

 +22       IF '$$USESSAN^RAHLRU1()

               SET RASEQ=RASEQ+1

               if RASEQ<6!(RABAR)

                   WRITE !,RACN,?6,RADISP,?7,$SELECT(RABAR:RACODE,1:""),?10,$EXTRACT(RAPR1,1,28),?39,$EXTRACT(RADATE,1,11),?51,$EXTRACT(RAST,1,12),?67,$EXTRACT(RALOC,1,12)

 +23       IF $EXTRACT(IOST,1,2)="C-"

               IF ($Y>(IOSL-4))

                   Begin DoDot:1

 +24                   NEW DIR

                       SET DIR(0)="E"

                       DO ^DIR

                       SET RAXIT=$SELECT(Y'>0:1,1:0)

 +25                   IF 'RAXIT

                           WRITE @IOF

                           DO HDR

 +26                   QUIT 

                   End DoDot:1

 +27       QUIT 

ORDER     ; Check for pat rad orders before registering a patient in rad

 +1       ; Created by GJC@1/3/94

 +2        NEW RALP,RA751,DIROUT,DIRUT,DTOUT,DUOUT

           SET (RALP,RAXIT)=0

 +3        FOR 

               SET RALP=$ORDER(^RAO(75.1,"B",RADFN,RALP))

               if RALP'>0!(RAXIT)

                   QUIT 

               Begin DoDot:1

 +4       ;check if the order for this patient has been registered

 +5                if $DATA(^RADPT("AO",RALP,RADFN))\10

                       QUIT 

 +6       ;if the order status is discontinued (1), complete (2) or

 +7       ;cancelled (13) quit gjc RA5P169

 +8                SET RA751(0)=$GET(^RAO(75.1,RALP,0))

                   SET RA751(5)=+$PIECE(RA751(0),U,5)

 +9                IF RA751(5)<3!(RA751(5)=13)

                       QUIT 

 +10               SET RA751(2)=$PIECE(RA751(0),U,2)

                   SET RA751(16)=$PIECE(RA751(0),U,16)

 +11               SET RA751(20)=$PIECE(RA751(0),U,20)

 +12               SET Y=RA751(2)

                   SET C=$PIECE($GET(^DD(75.1,2,0)),U,2)

                   if Y]""

                       DO Y^DIQ

                   SET RA751(2)=Y

 +13               SET Y=RA751(20)

                   SET C=$PIECE($GET(^DD(75.1,20,0)),U,2)

                   if Y]""

                       DO Y^DIQ

                   SET RA751(20)=Y

 +14               IF $$USESSAN^RAHLRU1()

                       WRITE !?18,$EXTRACT(RA751(2),1,28),?56,"Ord "

 +15               IF '$$USESSAN^RAHLRU1()

                       WRITE !?10,$EXTRACT(RA751(2),1,28),?51,"Ord "

 +16               WRITE $SELECT(RA751(16)]"":$$FMTE^XLFDT(RA751(16),"2D"),1:"")

 +17      ; prints 'SUBMIT REQUEST TO' data

 +18               IF $$USESSAN^RAHLRU1()

                       WRITE ?68,$EXTRACT(RA751(20),1,12)

 +19               IF '$$USESSAN^RAHLRU1()

                       WRITE ?67,$EXTRACT(RA751(20),1,12)

 +20               IF $EXTRACT(IOST,1,2)="C-"

                       IF ($Y>(IOSL-4))

                           Begin DoDot:2

 +21                           KILL DIR

                               SET DIR(0)="E"

                               DO ^DIR

                               KILL DIR

                               if '+Y

                                   SET RAXIT=1

 +22                           IF 'RAXIT

                                   WRITE @IOF

                                   DO HDR

 +23                           QUIT 

                           End DoDot:2

 +24               QUIT 

               End DoDot:1

 +25       QUIT 

HDR       ; Header

 +1       ; Created by GJC@1/3/94 ; modified for SSAN by RTK 3/19/09

 +2       ; The variable: RAOPT("ORDEREXAM") is defined in the entry action of

 +3       ; the option RA ORDEREXAM.  It is subsequently kill in the exit action

 +4       ; of the option.

 +5        DO HOME^%ZIS

           if $DATA(RAOPT("ORDEREXAM"))#2

               WRITE @IOF

 +6        IF $$USESSAN^RAHLRU1()

               WRITE !!,"Case #",?18,"Last 5 Procedures/New Orders",?47,"Exam Dt",?56,"Exam Status",?68,"Imaging Loc."

 +7        IF $$USESSAN^RAHLRU1()

               WRITE !,"----------------",?18,"----------------------------",?47,"--------",?56,"-----------",?68,"------------"

 +8        IF '$$USESSAN^RAHLRU1()

               WRITE !!,"Case #",?10,"Last 5 Procedures/New Orders",?39,"Exam Date",?51,"Status of Exam",?67,"Imaging Loc."

 +9        IF '$$USESSAN^RAHLRU1()

               WRITE !,"------",?10,"----------------------------",?39,"---------",?51,"--------------",?67,"------------"

 +10       QUIT 

 +11      ;

CM(RADFN,RADTI,RACNI) ;Return the contrast media used while performing an

 +1       ;exam.

 +2       ;Input: RADFN=patient DFN

 +3       ;       RADTI=inverse date/time of exam

 +4       ;       RACNI=IEN of an individual case

 +5       ;Return: contrast media used with exam delimited by ', '.

 +6        NEW I,X

           SET X=""

           SET I=0

 +7        FOR 

               SET I=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",I))

               if 'I

                   QUIT 

               Begin DoDot:1

 +8                SET I(0)=$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",I,0),U)

 +9                SET X=X_$$EXTERNAL^DILFD(70.3225,.01,"",I(0))_", "

 +10               QUIT 

               End DoDot:1

 +11       IF $LENGTH(X,", ")'>2

               SET X=$PIECE(X,", ")

 +12      IF '$TEST

               SET X=$PIECE(X,", ",1,($LENGTH(X,", ")-1))

 +13       QUIT X

 +14      ;