MAGDRA1.m

MAGDRA1 ;WOIFO/LB,JSL,SAF -Routine for DICOM fix ; 09/15/2004  13:34

 ;;3.0;IMAGING;**10,11,30,123**;Mar 19, 2002;Build 67;Jul 24, 2012

 ;; Per VHA Directive 2004-038, this routine should not be modified.

 ;; +---------------------------------------------------------------+

 ;; | Property of the US Government.                                |

 ;; | No permission to copy or redistribute this software is given. |

 ;; | Use of unreleased versions of this software requires the user |

 ;; | to execute a written test agreement with the VistA Imaging    |

 ;; | Development Office of the Department of Veterans Affairs,     |

 ;; | telephone (301) 734-0100.                                     |

 ;; | The Food and Drug Administration classifies this software as  |

 ;; | a medical device.  As such, it may not be changed in any way. |

 ;; | Modifications to this software may result in an adulterated   |

 ;; | medical device under 21CFR820, the use of which is considered |

 ;; | to be a violation of US Federal Statutes.                     |

 ;; +---------------------------------------------------------------+

 ;;

 Q

LOOP ;Loop thru ^TMP($J,"RAE1" global

 ;MAGDFN should exist.

 ;MAGNME,MAGPID may exist.

 Q:'$D(^TMP($J,"RAE1"))!('$D(MAGDFN))

 N CCASE,CASE,CDATE,CODE,DATA,DATE,ENTRY,ENTRIES,ERR,ESTAT,INDEX

 N LOC,MAGCASE,MAGCNI,MAGCPT,MAGDTI,MAGPIEN,MAGPRC,MAGPSET,MAGPST

 N OUT,OLDCNI,OLDDT,OLDENTRY,PROC,PSET,PTINFO,RARPT,RADTI,RACNI,RADFN

 N RAMELOW,RAPRTSET,REIN,STAT,X,Y

 S (ENTRY,ENTRIES,OLDDT)=0

 F  S ENTRY=$O(^TMP($J,"RAE1",MAGDFN,ENTRY)) Q:'ENTRY!$G(OUT)  D

 . S DATA=^TMP($J,"RAE1",MAGDFN,ENTRY),ENTRIES=ENTRIES+1

 . S DATE=$P(ENTRY,"-"),CDATE=9999999.9999-DATE

 . S DATE=$TR($$FMTE^XLFDT(CDATE,"2FD")," ","0")

 . S PROC=$P(DATA,"^"),CASE=$P(DATA,"^",2),STAT=$P(DATA,"^",6)

 . S ESTAT=$P(STAT,"~",2),LOC=$P(DATA,"^",7)

 . S RARPT=$P(DATA,"^",5)

 . S RADTI=$P(ENTRY,"-"),RACNI=$P(ENTRY,"-",2),RADFN=MAGDFN

 . S MAGCASE=$$LCASE^MAGDRA2(CDATE,CASE)

 . ;Above radiology variables needed for EN1^RAULT20

 . K RAMELOW,RAPRTSET

 . D EN1^RAUTL20

 . S (PSET,MAGPSET)=""

 . I OLDDT'=RADTI S OLDCNI=""

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

 . I PSET="+" S OLDCNI=RACNI

 . I PSET=".",OLDCNI D

 . . N OLDENTRY S OLDENTRY=$P(ENTRY,"-")_"-"_OLDCNI

 . . I $D(^TMP($J,"RAE1",MAGDFN,OLDENTRY)) D

 . . . S MAGCASE=$P(^TMP($J,"RAE1",MAGDFN,OLDENTRY),"^",2)

 . . . S CDATE=$P(ENTRY,"-")

 . . . S CDATE=9999999.9999-CDATE,RADTI=$P(OLDENTRY,"-"),RACNI=OLDCNI

 . . . S MAGCASE=$$LCASE^MAGDRA2(CDATE,MAGCASE)

 . . . S MAGPSET=CASE_" is part of this printset."

 . . . Q

 . . Q

 . I '$D(MAGNME)!'($D(MAGPID)) D

 . . S PTINFO=$$PTINFO^MAGDRA2

 . . S MAGNME=$P(PTINFO,"^"),MAGPID=$P(PTINFO,"^",2) ;P123

 . . Q

 . S INDEX(ENTRIES)=PROC_"^"_$G(MAGPSET)_"^"_RADTI_"^"_RACNI_"^"_MAGCASE

 . ; Radiology procedure^Printset^Inverse radiology date/time^Radioloty multiple^radiology case number

 . D PRT S OLDDT=RADTI

 . Q

 D:'$G(OUT) SEL I +X,$D(INDEX(+X)) D SET

 K OUT

 Q

PRT ;

 S (X,Y)=0

 I ENTRIES=1 D HEAD

 I $Y+6>IOSL D HEAD

 W !?1,ENTRIES,?5,PSET,?6,CASE_$$IMG^MAGDRA2(RARPT),?12,$E(PROC,1,28)

 W ?41,DATE,?52,$E(ESTAT,1,12),?67,$E(LOC,1,12) Q:ENTRIES#15

 D SEL

 Q

HEAD ;

 W @IOF,"Patient: ",MAGNME,?50,$$PIDLABEL^MAGSPID(),": ",MAGPID ;P123

 W !!,?3,"Case #",?12,"Procedure",?41,"Exam Date",?52,"Status of"

 W "Exam",?69,"Imaging Loc"

 W !?3,"--------",?12,"-------------",?41,"---------"

 W ?52,"--------------",?67,"-----------"

 Q

SEL ;

 N DIR ; -- array for FileMan prompt data

 S DIR(0)="NAO^1:"_ENTRIES

 S DIR("?",1)="Enter a number between 1 and "_ENTRIES

 S DIR("?")="corresponding to a single exam you wish to select."

 S DIR("A",1)="'i' next to a case number denotes images collected on study."

 S DIR("A")="Select an exam: "

 D ^DIR

 I '$D(DTOUT),'$D(DUOUT) ; didn't time out or uparrow out

 E  S OUT=1 Q

 I Y,$D(INDEX(Y)) D CHECK I 'Y G SEL

 I Y S Y=INDEX(Y) S OUT=1

 Q

SET ;

 S DATA=Y K Y

 S MAGCASE=$P(INDEX(+X),"^",5)

 S MAGPRC=$P(INDEX(+X),"^"),MAGPIEN=$$PROC^MAGDRA2(MAGPRC)

 S MAGDTI=$P(INDEX(+X),"^",3)

 S MAGPST=$P(INDEX(+X),"^",2)

 S MAGCNI=$P(INDEX(+X),"^",4)

 D MAGDY^MAGDRA2

 Q

CHECK ;

 ;Check to see if the entry still exists.

 N RADTI,CNI

 Q:'MAGDFN

 S RADTI=$P(INDEX(Y),"^",3),CNI=$P(INDEX(Y),"^",4)

 I '$D(^RADPT(MAGDFN,"DT",RADTI,"P",CNI)) D

 . S Y=""

 . W !,"There is a database problem with the entry selected.",!

 . Q

 I $P(INDEX(Y),"^")="" D

 . S Y=""

 . W !,"There are no procedures for the entry selected.",!

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---MAGDRA1   4556     printed  Feb 18, 2025@23:27:40                                                                                                                                                                                                     Page 2

MAGDRA1   ;WOIFO/LB,JSL,SAF -Routine for DICOM fix ; 09/15/2004  13:34

 +1       ;;3.0;IMAGING;**10,11,30,123**;Mar 19, 2002;Build 67;Jul 24, 2012

 +2       ;; Per VHA Directive 2004-038, this routine should not be modified.

 +3       ;; +---------------------------------------------------------------+

 +4       ;; | Property of the US Government.                                |

 +5       ;; | No permission to copy or redistribute this software is given. |

 +6       ;; | Use of unreleased versions of this software requires the user |

 +7       ;; | to execute a written test agreement with the VistA Imaging    |

 +8       ;; | Development Office of the Department of Veterans Affairs,     |

 +9       ;; | telephone (301) 734-0100.                                     |

 +10      ;; | The Food and Drug Administration classifies this software as  |

 +11      ;; | a medical device.  As such, it may not be changed in any way. |

 +12      ;; | Modifications to this software may result in an adulterated   |

 +13      ;; | medical device under 21CFR820, the use of which is considered |

 +14      ;; | to be a violation of US Federal Statutes.                     |

 +15      ;; +---------------------------------------------------------------+

 +16      ;;

 +17       QUIT 

LOOP      ;Loop thru ^TMP($J,"RAE1" global

 +1       ;MAGDFN should exist.

 +2       ;MAGNME,MAGPID may exist.

 +3        if '$DATA(^TMP($JOB,"RAE1"))!('$DATA(MAGDFN))

               QUIT 

 +4        NEW CCASE,CASE,CDATE,CODE,DATA,DATE,ENTRY,ENTRIES,ERR,ESTAT,INDEX

 +5        NEW LOC,MAGCASE,MAGCNI,MAGCPT,MAGDTI,MAGPIEN,MAGPRC,MAGPSET,MAGPST

 +6        NEW OUT,OLDCNI,OLDDT,OLDENTRY,PROC,PSET,PTINFO,RARPT,RADTI,RACNI,RADFN

 +7        NEW RAMELOW,RAPRTSET,REIN,STAT,X,Y

 +8        SET (ENTRY,ENTRIES,OLDDT)=0

 +9        FOR 

               SET ENTRY=$ORDER(^TMP($JOB,"RAE1",MAGDFN,ENTRY))

               if 'ENTRY!$GET(OUT)

                   QUIT 

               Begin DoDot:1

 +10               SET DATA=^TMP($JOB,"RAE1",MAGDFN,ENTRY)

                   SET ENTRIES=ENTRIES+1

 +11               SET DATE=$PIECE(ENTRY,"-")

                   SET CDATE=9999999.9999-DATE

 +12               SET DATE=$TRANSLATE($$FMTE^XLFDT(CDATE,"2FD")," ","0")

 +13               SET PROC=$PIECE(DATA,"^")

                   SET CASE=$PIECE(DATA,"^",2)

                   SET STAT=$PIECE(DATA,"^",6)

 +14               SET ESTAT=$PIECE(STAT,"~",2)

                   SET LOC=$PIECE(DATA,"^",7)

 +15               SET RARPT=$PIECE(DATA,"^",5)

 +16               SET RADTI=$PIECE(ENTRY,"-")

                   SET RACNI=$PIECE(ENTRY,"-",2)

                   SET RADFN=MAGDFN

 +17               SET MAGCASE=$$LCASE^MAGDRA2(CDATE,CASE)

 +18      ;Above radiology variables needed for EN1^RAULT20

 +19               KILL RAMELOW,RAPRTSET

 +20               DO EN1^RAUTL20

 +21               SET (PSET,MAGPSET)=""

 +22               IF OLDDT'=RADTI

                       SET OLDCNI=""

 +23               SET PSET=$SELECT(RAMEMLOW:"+",RAPRTSET:".",1:"")

 +24               IF PSET="+"

                       SET OLDCNI=RACNI

 +25               IF PSET="."

                       IF OLDCNI

                           Begin DoDot:2

 +26                           NEW OLDENTRY

                               SET OLDENTRY=$PIECE(ENTRY,"-")_"-"_OLDCNI

 +27                           IF $DATA(^TMP($JOB,"RAE1",MAGDFN,OLDENTRY))

                                   Begin DoDot:3

 +28                                   SET MAGCASE=$PIECE(^TMP($JOB,"RAE1",MAGDFN,OLDENTRY),"^",2)

 +29                                   SET CDATE=$PIECE(ENTRY,"-")

 +30                                   SET CDATE=9999999.9999-CDATE

                                       SET RADTI=$PIECE(OLDENTRY,"-")

                                       SET RACNI=OLDCNI

 +31                                   SET MAGCASE=$$LCASE^MAGDRA2(CDATE,MAGCASE)

 +32                                   SET MAGPSET=CASE_" is part of this printset."

 +33                                   QUIT 

                                   End DoDot:3

 +34                           QUIT 

                           End DoDot:2

 +35               IF '$DATA(MAGNME)!'($DATA(MAGPID))

                       Begin DoDot:2

 +36                       SET PTINFO=$$PTINFO^MAGDRA2

 +37      ;P123

                           SET MAGNME=$PIECE(PTINFO,"^")

                           SET MAGPID=$PIECE(PTINFO,"^",2)

 +38                       QUIT 

                       End DoDot:2

 +39               SET INDEX(ENTRIES)=PROC_"^"_$GET(MAGPSET)_"^"_RADTI_"^"_RACNI_"^"_MAGCASE

 +40      ; Radiology procedure^Printset^Inverse radiology date/time^Radioloty multiple^radiology case number

 +41               DO PRT

                   SET OLDDT=RADTI

 +42               QUIT 

               End DoDot:1

 +43       if '$GET(OUT)

               DO SEL

           IF +X

               IF $DATA(INDEX(+X))

                   DO SET

 +44       KILL OUT

 +45       QUIT 

PRT       ;

 +1        SET (X,Y)=0

 +2        IF ENTRIES=1

               DO HEAD

 +3        IF $Y+6>IOSL

               DO HEAD

 +4        WRITE !?1,ENTRIES,?5,PSET,?6,CASE_$$IMG^MAGDRA2(RARPT),?12,$EXTRACT(PROC,1,28)

 +5        WRITE ?41,DATE,?52,$EXTRACT(ESTAT,1,12),?67,$EXTRACT(LOC,1,12)

           if ENTRIES#15

               QUIT 

 +6        DO SEL

 +7        QUIT 

HEAD      ;

 +1       ;P123

           WRITE @IOF,"Patient: ",MAGNME,?50,$$PIDLABEL^MAGSPID(),": ",MAGPID

 +2        WRITE !!,?3,"Case #",?12,"Procedure",?41,"Exam Date",?52,"Status of"

 +3        WRITE "Exam",?69,"Imaging Loc"

 +4        WRITE !?3,"--------",?12,"-------------",?41,"---------"

 +5        WRITE ?52,"--------------",?67,"-----------"

 +6        QUIT 

SEL       ;

 +1       ; -- array for FileMan prompt data

           NEW DIR

 +2        SET DIR(0)="NAO^1:"_ENTRIES

 +3        SET DIR("?",1)="Enter a number between 1 and "_ENTRIES

 +4        SET DIR("?")="corresponding to a single exam you wish to select."

 +5        SET DIR("A",1)="'i' next to a case number denotes images collected on study."

 +6        SET DIR("A")="Select an exam: "

 +7        DO ^DIR

 +8       ; didn't time out or uparrow out

           IF '$DATA(DTOUT)

               IF '$DATA(DUOUT)

 +9       IF '$TEST

               SET OUT=1

               QUIT 

 +10       IF Y

               IF $DATA(INDEX(Y))

                   DO CHECK

                   IF 'Y

                       GOTO SEL

 +11       IF Y

               SET Y=INDEX(Y)

               SET OUT=1

 +12       QUIT 

SET       ;

 +1        SET DATA=Y

           KILL Y

 +2        SET MAGCASE=$PIECE(INDEX(+X),"^",5)

 +3        SET MAGPRC=$PIECE(INDEX(+X),"^")

           SET MAGPIEN=$$PROC^MAGDRA2(MAGPRC)

 +4        SET MAGDTI=$PIECE(INDEX(+X),"^",3)

 +5        SET MAGPST=$PIECE(INDEX(+X),"^",2)

 +6        SET MAGCNI=$PIECE(INDEX(+X),"^",4)

 +7        DO MAGDY^MAGDRA2

 +8        QUIT 

CHECK     ;

 +1       ;Check to see if the entry still exists.

 +2        NEW RADTI,CNI

 +3        if 'MAGDFN

               QUIT 

 +4        SET RADTI=$PIECE(INDEX(Y),"^",3)

           SET CNI=$PIECE(INDEX(Y),"^",4)

 +5        IF '$DATA(^RADPT(MAGDFN,"DT",RADTI,"P",CNI))

               Begin DoDot:1

 +6                SET Y=""

 +7                WRITE !,"There is a database problem with the entry selected.",!

 +8                QUIT 

               End DoDot:1

 +9        IF $PIECE(INDEX(Y),"^")=""

               Begin DoDot:1

 +10               SET Y=""

 +11               WRITE !,"There are no procedures for the entry selected.",!

               End DoDot:1

 +12       QUIT