- RASYNCHLU ;HISC/GJC-Case Number Lookup Synch Logic ; Mar 24, 2023@13:19:45
- ;;5.0;Radiology/Nuclear Medicine;**198**;Mar 16, 1998;Build 1
- ;
- ;Routine File IA Type
- ;----------------------------------------------
- ; 100 6475 (C)
- ;
- EN ;Entry point for 'Synch Canceled/Completed Exams with CPRS & RIS Orders'
- ;note: RADFN is defined after successfully selecting a radiology patient record from ^RADPA
- ;Returns: RAQS the user selection (globally scoped local)
- ;
- I '$D(RADFN)#2 W !!?2,"Patient information is missing, exiting the option." QUIT
- N RABS5,RACEXST,RACPRS,RADATE,RADIV,RADTPRT,RAEXDT,RAEXST,RAHDFLG,RAHDR,RAI,RAII,RAIMAGE
- N RAOIFN,RAORIFN,RAORSTS,RAPRC,RAPTNAME,RAREQST,RAROOT,RASSN,RAX,RAY2,RAY3,RAXIT
- S (RAHDFLG,RACNT,RAXIT)=0,RAHDR="<<<< Synch Exams with CPRS/Radiology Orders >>>>"
- D SEL Q:$O(^TMP($J,"RASYNCH",0))'>0
- ;now display the existing data
- S RAI=0,RAROOT=$NA(^TMP($J,"RASYNCH"))
- F S RAI=$O(@RAROOT@(RAI)) Q:RAI'>0 D Q:RAXIT>0!(RAQS>0)
- .S RAX=$G(@RAROOT@(RAI))
- .F RAII=1:1:7 S @$P("RADFN^RADTI^RADTE^RACNI^RACN^RAOIFN^RAACC","^",RAII)=$P(RAX,"^",RAII)
- .D SETUP,DATA
- .Q
- Q
- ;
- SEL ; selection criteria part one
- Q:'$D(^DPT(RADFN,0))#2 S RADFN(0)=$G(^DPT(RADFN,0)),RASSN=$$SSN^RAUTL,RAPTNAME=$P(RADFN(0),"^")
- D HOME^%ZIS S (RACNT,RADTI,RAQS)=0
- F S RADTI=$O(^RADPT(RADFN,"DT",RADTI)) Q:RADTI'>0 D Q:RAQS>0!(RAXIT>0)
- .S RAY2=$G(^RADPT(RADFN,"DT",RADTI,0)),RADTE=+$P(RAY2,U) D SEL2
- .Q
- Q
- ;
- SEL2 ; selection criteria part two
- S RADIV=+$P(RAY2,U,3),RAIMAGE=+$P(RAY2,U,2)
- S RADIV=+$G(^RA(79,RADIV,0)),RADIV=$P($G(^DIC(4,RADIV,0)),U)
- S:RADIV']"" RADIV="Unknown"
- S RAIMAGE=$P($G(^RA(79.2,RAIMAGE,0)),U)
- S:RAIMAGE']"" RAIMAGE="Unknown" S RACNI=0
- F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 D Q:RAQS>0!(RAXIT>0)
- .S RAY3=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S RACN=+$P(RAY3,U)
- .D SAVE
- .QUIT
- Q
- SAVE ; Screen only if entered through Rad/Nuc Med must be canceled/completed exams (determined by order #)
- S RAEXST=+$P(RAY3,U,3),RAEXST(0)=$G(^RA(72,RAEXST,0))
- Q:RAEXST(0)="" S RAEXST(1)=$P(RAEXST(0),U)
- ;quit if exam is not canceled or not complete
- I $P(RAEXST(0),U,3)'=0,($P(RAEXST(0),U,3)'=9) Q
- S RACN=$P(RAY3,U) S:RACN="" RACN="error"
- S RAEXDT=$E(RADTE,4,5)_"/"_$E(RADTE,6,7)_"/"_$E(RADTE,2,3)
- S RAPRC(0)=$G(^RAMIS(71,+$P(RAY3,U,2),0)),RAPRC=$P(RAPRC(0),U)
- S RAOIFN=+$P(RAY3,U,11),RAOIFN(0)=$G(^RAO(75.1,RAOIFN,0))
- ;
- ;we do not care what the RIS order status is; we only care that the CPRS order
- ;status is 'ACTIVE'. Get RIS request status name, check CPRS order to see if active.
- S RAREQST=$$GET1^DIQ(75.1,RAOIFN_",",5) ;RIS external
- S RAORIFN=+$P(RAOIFN(0),U,7) ;CPRS ptr to file #100
- S RAORSTS=$$GET1^DIQ(100,RAORIFN_",",5) ;CPRS external
- Q:RAORSTS'="ACTIVE" ;CPRS order must be ACTIVE
- ;
- ;check our active order to see if there are other non-canceled exams tied to it
- ;if true do not discontinue the orders; else discontinue the order(s)
- ;
- I $P(RAEXST(0),U,3)=0 Q:$$OTHERS(RAOIFN,RADFN)
- ;
- ;-- accession #
- I $P(RAY3,U,31)'="" S RAACC=$P(RAY3,U,31)
- E S RAACC=$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_RACN
- ;--
- S (RADTPRT,Y)=RADTE D D^RAUTL S RADATE=Y,RACNT=RACNT+1
- S ^TMP($J,"RASYNCH",RACNT)=RADFN_U_RADTI_U_RADTE_U_RACNI_U_RACN_U_RAOIFN_U_RAACC
- Q
- ;
- DATA ;display data here
- ;RAROOT = $NA(^TMP($J,"RASYNCH",RACNT))
- D:RAHDFLG=0 HD ;mimics 'Case No. Exam Edit' & 'Edit Exam by Patient' options screen display
- ;
- S RACEXST=$P($G(^RA(72,+$P(RAY3,U,3),0)),U)
- W !,RAI,?4,RAACC,?21,$E(RAPRC,1,17),?41,RAEXDT,?52,$E(RACEXST,1,9),?62,RAORIFN
- ;condition: if at end of screen check and more patient data stop and ask user for a selection
- ;the user can enter return at the selection prompt (RAQS=0) move to next set of data
- I (($Y+4)>IOSL) D
- .D USRSEL Q:RAXIT>0!(RAQS>0)
- .W:$O(@RAROOT@(RAI))>0 @IOF
- .Q
- ;condition: if not at end of screen and no more patient data ask user for their choice
- E D:$O(@RAROOT@(RAI))'>0 USRSEL
- Q
- ;
- HD ;print header once
- S RAHDFLG=1,RABS5=" ("_$E(RAPTNAME,1)_$P(RASSN,"-",3)_")"
- W @IOF,?25,RAHDR,!!,"Patient's Name: ",$E(RAPTNAME,1,20),RABS5,?59,"Run Date: " S Y=DT D DT^DIO2
- W !!,$$CJ^XLFSTR("========== Synch Exams with CPRS/Radiology Orders ==========",IOM)
- W !!?4,"Accession #",?21,"Procedure",?41,"Exam DT",?52,"Exam ST",?62,"CPRS Order #"
- W !?4,"-----------",?21,"---------",?41,"-------",?52,"-------",?62,"------------" Q
- Q
- ;
- USRSEL ;prompt user for selection.
- ;Input : RACNT = # of records displayed
- ;Output: RAQS = the # (between 1 & RACNT) of user's selection
- N DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,X,Y
- S DIR(0)="NO^1:"_RAI_":0",DIR("A")="Enter your numeric selection"
- S DIR("?",1)="Enter the number identifying the accession number of the exam to"
- S DIR("?",2)="be re-synchronized. Only one exam can be re-synchronized at a time."
- S DIR("?")="Enter a number between 1 and "_RAI_"." D ^DIR
- I $D(DTOUT)#2!($D(DUOUT)#2)!($D(DIROUT)#2) S RAXIT=1 QUIT
- S RAQS=+Y
- QUIT
- ;
- SETUP ;setup basic exam and order data.
- S RAY2=$G(^RADPT(RADFN,"DT",RADTI,0)) Q:RAY2=""
- S RAY3=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) Q:RAY3=""
- S RAPRC(0)=$G(^RAMIS(71,+$P(RAY3,U,2),0)),RAPRC=$P(RAPRC(0),U)
- S RAEXDT=$E(RADTE,4,5)_"/"_$E(RADTE,6,7)_"/"_$E(RADTE,2,3)
- S RAOIFN=+$P(RAY3,U,11),RAOIFN(0)=$G(^RAO(75.1,RAOIFN,0))
- S RAREQST=$$GET1^DIQ(75.1,RAOIFN_",",5) ;RIS external
- S RAORIFN=+$P(RAOIFN(0),U,7) ;CPRS ptr to file #100
- S RAORSTS=$$GET1^DIQ(100,RAORIFN_",",5) ;CPRS external
- QUIT
- ;
- OTHERS(RAOIFN,RADFN) ;are there other non-canceled exams tied
- ;to this order?
- ; Input: RAOIFN = RIS order IEN
- ; RADFN = DFN of patient
- ;
- ; returns: RAR: 1 if another non-canceled exam is tied to the RIS order
- ; else 0 (the default)
- N RA0,RA1,RA72,RAA,RAC,RAQ,RAR S (RA1,RAR)=0
- F S RA1=$O(^RADPT("AO",RAOIFN,RADFN,RA1)) Q:RA1'>0 D Q:RAR
- .S RA0=0 F S RA0=$O(^RADPT("AO",RAOIFN,RADFN,RA1,RA0)) Q:RA0'>0 D Q:RAR
- ..S RAQ=$G(^RADPT(RADFN,"DT",RA1,"P",RA0,0)) Q:RAQ="" ;bad data
- ..S RA72=+$P(RAQ,U,3),RA72(0)=$G(^RA(72,RA72,0))
- ..S:$P(RA72(0),U,3)>0 RAR=1
- ..Q
- .Q
- Q RAR
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRASYNCHLU 6224 printed Feb 19, 2025@00:06:17 Page 2
- RASYNCHLU ;HISC/GJC-Case Number Lookup Synch Logic ; Mar 24, 2023@13:19:45
- +1 ;;5.0;Radiology/Nuclear Medicine;**198**;Mar 16, 1998;Build 1
- +2 ;
- +3 ;Routine File IA Type
- +4 ;----------------------------------------------
- +5 ; 100 6475 (C)
- +6 ;
- EN ;Entry point for 'Synch Canceled/Completed Exams with CPRS & RIS Orders'
- +1 ;note: RADFN is defined after successfully selecting a radiology patient record from ^RADPA
- +2 ;Returns: RAQS the user selection (globally scoped local)
- +3 ;
- +4 IF '$DATA(RADFN)#2
- WRITE !!?2,"Patient information is missing, exiting the option."
- QUIT
- +5 NEW RABS5,RACEXST,RACPRS,RADATE,RADIV,RADTPRT,RAEXDT,RAEXST,RAHDFLG,RAHDR,RAI,RAII,RAIMAGE
- +6 NEW RAOIFN,RAORIFN,RAORSTS,RAPRC,RAPTNAME,RAREQST,RAROOT,RASSN,RAX,RAY2,RAY3,RAXIT
- +7 SET (RAHDFLG,RACNT,RAXIT)=0
- SET RAHDR="<<<< Synch Exams with CPRS/Radiology Orders >>>>"
- +8 DO SEL
- if $ORDER(^TMP($JOB,"RASYNCH",0))'>0
- QUIT
- +9 ;now display the existing data
- +10 SET RAI=0
- SET RAROOT=$NAME(^TMP($JOB,"RASYNCH"))
- +11 FOR
- SET RAI=$ORDER(@RAROOT@(RAI))
- if RAI'>0
- QUIT
- Begin DoDot:1
- +12 SET RAX=$GET(@RAROOT@(RAI))
- +13 FOR RAII=1:1:7
- SET @$PIECE("RADFN^RADTI^RADTE^RACNI^RACN^RAOIFN^RAACC","^",RAII)=$PIECE(RAX,"^",RAII)
- +14 DO SETUP
- DO DATA
- +15 QUIT
- End DoDot:1
- if RAXIT>0!(RAQS>0)
- QUIT
- +16 QUIT
- +17 ;
- SEL ; selection criteria part one
- +1 if '$DATA(^DPT(RADFN,0))#2
- QUIT
- SET RADFN(0)=$GET(^DPT(RADFN,0))
- SET RASSN=$$SSN^RAUTL
- SET RAPTNAME=$PIECE(RADFN(0),"^")
- +2 DO HOME^%ZIS
- SET (RACNT,RADTI,RAQS)=0
- +3 FOR
- SET RADTI=$ORDER(^RADPT(RADFN,"DT",RADTI))
- if RADTI'>0
- QUIT
- Begin DoDot:1
- +4 SET RAY2=$GET(^RADPT(RADFN,"DT",RADTI,0))
- SET RADTE=+$PIECE(RAY2,U)
- DO SEL2
- +5 QUIT
- End DoDot:1
- if RAQS>0!(RAXIT>0)
- QUIT
- +6 QUIT
- +7 ;
- SEL2 ; selection criteria part two
- +1 SET RADIV=+$PIECE(RAY2,U,3)
- SET RAIMAGE=+$PIECE(RAY2,U,2)
- +2 SET RADIV=+$GET(^RA(79,RADIV,0))
- SET RADIV=$PIECE($GET(^DIC(4,RADIV,0)),U)
- +3 if RADIV']""
- SET RADIV="Unknown"
- +4 SET RAIMAGE=$PIECE($GET(^RA(79.2,RAIMAGE,0)),U)
- +5 if RAIMAGE']""
- SET RAIMAGE="Unknown"
- SET RACNI=0
- +6 FOR
- SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
- if RACNI'>0
- QUIT
- Begin DoDot:1
- +7 SET RAY3=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
- SET RACN=+$PIECE(RAY3,U)
- +8 DO SAVE
- +9 QUIT
- End DoDot:1
- if RAQS>0!(RAXIT>0)
- QUIT
- +10 QUIT
- SAVE ; Screen only if entered through Rad/Nuc Med must be canceled/completed exams (determined by order #)
- +1 SET RAEXST=+$PIECE(RAY3,U,3)
- SET RAEXST(0)=$GET(^RA(72,RAEXST,0))
- +2 if RAEXST(0)=""
- QUIT
- SET RAEXST(1)=$PIECE(RAEXST(0),U)
- +3 ;quit if exam is not canceled or not complete
- +4 IF $PIECE(RAEXST(0),U,3)'=0
- IF ($PIECE(RAEXST(0),U,3)'=9)
- QUIT
- +5 SET RACN=$PIECE(RAY3,U)
- if RACN=""
- SET RACN="error"
- +6 SET RAEXDT=$EXTRACT(RADTE,4,5)_"/"_$EXTRACT(RADTE,6,7)_"/"_$EXTRACT(RADTE,2,3)
- +7 SET RAPRC(0)=$GET(^RAMIS(71,+$PIECE(RAY3,U,2),0))
- SET RAPRC=$PIECE(RAPRC(0),U)
- +8 SET RAOIFN=+$PIECE(RAY3,U,11)
- SET RAOIFN(0)=$GET(^RAO(75.1,RAOIFN,0))
- +9 ;
- +10 ;we do not care what the RIS order status is; we only care that the CPRS order
- +11 ;status is 'ACTIVE'. Get RIS request status name, check CPRS order to see if active.
- +12 ;RIS external
- SET RAREQST=$$GET1^DIQ(75.1,RAOIFN_",",5)
- +13 ;CPRS ptr to file #100
- SET RAORIFN=+$PIECE(RAOIFN(0),U,7)
- +14 ;CPRS external
- SET RAORSTS=$$GET1^DIQ(100,RAORIFN_",",5)
- +15 ;CPRS order must be ACTIVE
- if RAORSTS'="ACTIVE"
- QUIT
- +16 ;
- +17 ;check our active order to see if there are other non-canceled exams tied to it
- +18 ;if true do not discontinue the orders; else discontinue the order(s)
- +19 ;
- +20 IF $PIECE(RAEXST(0),U,3)=0
- if $$OTHERS(RAOIFN,RADFN)
- QUIT
- +21 ;
- +22 ;-- accession #
- +23 IF $PIECE(RAY3,U,31)'=""
- SET RAACC=$PIECE(RAY3,U,31)
- +24 IF '$TEST
- SET RAACC=$EXTRACT(RADTE,4,7)_$EXTRACT(RADTE,2,3)_"-"_RACN
- +25 ;--
- +26 SET (RADTPRT,Y)=RADTE
- DO D^RAUTL
- SET RADATE=Y
- SET RACNT=RACNT+1
- +27 SET ^TMP($JOB,"RASYNCH",RACNT)=RADFN_U_RADTI_U_RADTE_U_RACNI_U_RACN_U_RAOIFN_U_RAACC
- +28 QUIT
- +29 ;
- DATA ;display data here
- +1 ;RAROOT = $NA(^TMP($J,"RASYNCH",RACNT))
- +2 ;mimics 'Case No. Exam Edit' & 'Edit Exam by Patient' options screen display
- if RAHDFLG=0
- DO HD
- +3 ;
- +4 SET RACEXST=$PIECE($GET(^RA(72,+$PIECE(RAY3,U,3),0)),U)
- +5 WRITE !,RAI,?4,RAACC,?21,$EXTRACT(RAPRC,1,17),?41,RAEXDT,?52,$EXTRACT(RACEXST,1,9),?62,RAORIFN
- +6 ;condition: if at end of screen check and more patient data stop and ask user for a selection
- +7 ;the user can enter return at the selection prompt (RAQS=0) move to next set of data
- +8 IF (($Y+4)>IOSL)
- Begin DoDot:1
- +9 DO USRSEL
- if RAXIT>0!(RAQS>0)
- QUIT
- +10 if $ORDER(@RAROOT@(RAI))>0
- WRITE @IOF
- +11 QUIT
- End DoDot:1
- +12 ;condition: if not at end of screen and no more patient data ask user for their choice
- +13 IF '$TEST
- if $ORDER(@RAROOT@(RAI))'>0
- DO USRSEL
- +14 QUIT
- +15 ;
- HD ;print header once
- +1 SET RAHDFLG=1
- SET RABS5=" ("_$EXTRACT(RAPTNAME,1)_$PIECE(RASSN,"-",3)_")"
- +2 WRITE @IOF,?25,RAHDR,!!,"Patient's Name: ",$EXTRACT(RAPTNAME,1,20),RABS5,?59,"Run Date: "
- SET Y=DT
- DO DT^DIO2
- +3 WRITE !!,$$CJ^XLFSTR("========== Synch Exams with CPRS/Radiology Orders ==========",IOM)
- +4 WRITE !!?4,"Accession #",?21,"Procedure",?41,"Exam DT",?52,"Exam ST",?62,"CPRS Order #"
- +5 WRITE !?4,"-----------",?21,"---------",?41,"-------",?52,"-------",?62,"------------"
- QUIT
- +6 QUIT
- +7 ;
- USRSEL ;prompt user for selection.
- +1 ;Input : RACNT = # of records displayed
- +2 ;Output: RAQS = the # (between 1 & RACNT) of user's selection
- +3 NEW DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,X,Y
- +4 SET DIR(0)="NO^1:"_RAI_":0"
- SET DIR("A")="Enter your numeric selection"
- +5 SET DIR("?",1)="Enter the number identifying the accession number of the exam to"
- +6 SET DIR("?",2)="be re-synchronized. Only one exam can be re-synchronized at a time."
- +7 SET DIR("?")="Enter a number between 1 and "_RAI_"."
- DO ^DIR
- +8 IF $DATA(DTOUT)#2!($DATA(DUOUT)#2)!($DATA(DIROUT)#2)
- SET RAXIT=1
- QUIT
- +9 SET RAQS=+Y
- +10 QUIT
- +11 ;
- SETUP ;setup basic exam and order data.
- +1 SET RAY2=$GET(^RADPT(RADFN,"DT",RADTI,0))
- if RAY2=""
- QUIT
- +2 SET RAY3=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
- if RAY3=""
- QUIT
- +3 SET RAPRC(0)=$GET(^RAMIS(71,+$PIECE(RAY3,U,2),0))
- SET RAPRC=$PIECE(RAPRC(0),U)
- +4 SET RAEXDT=$EXTRACT(RADTE,4,5)_"/"_$EXTRACT(RADTE,6,7)_"/"_$EXTRACT(RADTE,2,3)
- +5 SET RAOIFN=+$PIECE(RAY3,U,11)
- SET RAOIFN(0)=$GET(^RAO(75.1,RAOIFN,0))
- +6 ;RIS external
- SET RAREQST=$$GET1^DIQ(75.1,RAOIFN_",",5)
- +7 ;CPRS ptr to file #100
- SET RAORIFN=+$PIECE(RAOIFN(0),U,7)
- +8 ;CPRS external
- SET RAORSTS=$$GET1^DIQ(100,RAORIFN_",",5)
- +9 QUIT
- +10 ;
- OTHERS(RAOIFN,RADFN) ;are there other non-canceled exams tied
- +1 ;to this order?
- +2 ; Input: RAOIFN = RIS order IEN
- +3 ; RADFN = DFN of patient
- +4 ;
- +5 ; returns: RAR: 1 if another non-canceled exam is tied to the RIS order
- +6 ; else 0 (the default)
- +7 NEW RA0,RA1,RA72,RAA,RAC,RAQ,RAR
- SET (RA1,RAR)=0
- +8 FOR
- SET RA1=$ORDER(^RADPT("AO",RAOIFN,RADFN,RA1))
- if RA1'>0
- QUIT
- Begin DoDot:1
- +9 SET RA0=0
- FOR
- SET RA0=$ORDER(^RADPT("AO",RAOIFN,RADFN,RA1,RA0))
- if RA0'>0
- QUIT
- Begin DoDot:2
- +10 ;bad data
- SET RAQ=$GET(^RADPT(RADFN,"DT",RA1,"P",RA0,0))
- if RAQ=""
- QUIT
- +11 SET RA72=+$PIECE(RAQ,U,3)
- SET RA72(0)=$GET(^RA(72,RA72,0))
- +12 if $PIECE(RA72(0),U,3)>0
- SET RAR=1
- +13 QUIT
- End DoDot:2
- if RAR
- QUIT
- +14 QUIT
- End DoDot:1
- if RAR
- QUIT
- +15 QUIT RAR
- +16 ;