RAREG1 ;HISC/CAH,FPT,DAD AISC/MJK,RMO - Register Patient ; May 31, 2024@16:27:41
;;5.0;Radiology/Nuclear Medicine;**7,21,93,137,144,124,153,169,214**;Mar 16, 1998;Build 1
; 07/15/2008 BAY/KAM rem call 249750 RA*5*93 Correct DIK Calls
;
;Tag^Routine IA# Usage Custodian Subscriber
;----------------------------------------------------------------
;$$STA^XUAF4 2171 Supported Kernel
;
ASKORD I $D(RAVSTFLG),$G(YY)]"",$P(YY,U,5) D ASET G PACS
; radparfl = 1 if user chose detail-to-parent conversion
; radparpr = ien of file 74 of parent proc to replace detail proc
K RADPARPR,RADPARFL
S RAOLP=0,RAOVSTS="3;5;8" W ! D ^RAORDS G Q1:$D(RAOUT) G EXAM:$D(RAORDS)
S RARD("A")="Do you want to Request an Exam for "_RANME_"? ",RARD(0)="S",RARD(1)="Yes^enter a request.",RARD(2)="No^not enter a request.",RARD("B")=2 D SET^RARD K RARD G Q1:$E(X)'="Y"
W !!?3,"...requesting an exam for ",RANME,"...",! D ^RAORD1
;quit if the RAORDS array does not exist (no pending RIS orders filed for this event)
;RIS orders will exist but will they be ibn a 'canceled' REQUEST STATUS?
D CHKORDS(.RAORDS) ;pass in RAORDS array
QUIT:($D(RAORDS)\10)=0
;
EXAM ;
; block mixture of single proc with parent procedures
N RA6,RA7,RA8 S RA6="",RA7=0,RA8=0
F S RA6=$O(RAORDS(RA6)) Q:'RA6 S:$P($G(^RAMIS(71,$P(^RAO(75.1,+RAORDS(RA6),0),U,2),0)),U,6)="P" RA7=1 S:$P($G(^RAMIS(71,$P(^RAO(75.1,+RAORDS(RA6),0),U,2),0)),U,6)'="P" RA8=1
I RA7,RA8 W !!?7,$C(7),"You may not register a mixture of single and parent procedures.",! G Q1
;
I $G(RADPARFL) D G:Y<1 Q1 ; process detail-to-parent
. D PSETPNT^RAREG4
. Q
S RAPARENT=+$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,5)
K ^TMP($J,"RAREG1") S (RAEXIT,RAQUIT,RASKIPIT,RACNICNT)=0
D RSBIT^RAREG3
F RAOLP=1:1 S RAOIFN=$G(RAORDS(RAOLP)) Q:'RAOIFN!RAEXIT!RAQUIT D
. D PROCESS^RAREG4
. Q
I RAEXIT,RAPARENT D EXAMDEL^RAREG2
I $D(^TMP($J,"RAREG1")) D UOSM^RAREG2
PACS I $D(^TMP($J,"RAREG1")) S RACNT=0 F S RACNT=$O(^TMP($J,"RAREG1",RACNT)) Q:'RACNT D
.S RAREGTMP=$G(^TMP($J,"RAREG1",RACNT)),RADFN=$P(RAREGTMP,U,1),RADTI=$P(RAREGTMP,U,2),RACNI=$P(RAREGTMP,U,3)
.D REG^RAHLRPC
.Q
K RAREGTMP
D:$D(RADPARFL) CKDUPORD^RAREG2 ; ck for dupl procs in outstndg orders
Q I '$D(RAREC) W !!?3,$C(7),"No exams entered for this visit. Must delete..." S DA(1)=RADFN,DA=RADTI,DIK="^RADPT("_DA(1)_",""DT""," D ^DIK W "...deletion complete!" K RAPX
D PRNRQ^RAREG3 ;print request when exam is registered - P137 /KLM
D LABEL^RAREG3
Q1 D Q4^RAREG4
G PAT^RAREG
;
;CN entry point is called every time a new case number is assigned.
;The next available CN and last date CN's were "recycled" is stored in
;^RA(79.2,1,"CN")=Next availabe CN ^ date last recycled.
;This routine uses the next available CN unless it has been used for
;the same exam date before (DUP checks for duplicate case/date pair).
;Then the next available CN is calculated and written to the first
;piece of ^RA(79.2,1,"CN"). The node is locked during this transaction.
CN ;VARIABLES RATYPE,RADT AND RASET MUST EXIST AT THIS POINT
; 11/05/2008 BAY/KAM rem call 273496 RA*5*93 Add lock timeout to next line
L +^RA(79.2,RATYPE,"CN"):$S($G(DILOCKTM)>0:DILOCKTM,1:3) D CAL:'$D(^RA(79.2,RATYPE,"CN")),CAL:DT>$P(^("CN"),"^",2),CAL:+^("CN")>99999 S RAX=+^RA(79.2,RATYPE,"CN") D DUP
; need recalculate if DUP returns an over 99999 value
I RAX>99999 D CAL S RAX=+^RA(79.2,RATYPE,"CN") D DUP
I 'RASET S X=RAX G CNQ
I $D(X),X'="N",X'=RAX W !!,$C(7),"New case number must be equal to '",RAX,"'. OK? YES// " R RANS:DTIME K X I RANS["N"!(RANS["n")!('$T) G CNQ
S X=RAX
; get next available short case number for future registration
; re-set "CN" node if future short case number >99999
; NOTE1: find and store next free case number for future use 091300
F RAJ=(^RA(79.2,RATYPE,"CN")+1):1 I '$D(^RADPT("AE",RAJ)) S ^("CN")=RAJ_"^"_$P(^RA(79.2,RATYPE,"CN"),"^",2) Q
; if the next free case no. for future use is >99999, need recalculate
I +^RA(79.2,RATYPE,"CN")>99999 D CAL
CNQ L -^RA(79.2,RATYPE,"CN")
I $D(X),X>99999 W !!?3,$C(7),"You have reached the maximum limit for case numbers (99,999).",!?3,"You must first complete/purge your old exams before you can proceed." K X
K RAJ,RATYPE,RASET,RAX,RANS,RADT Q
DUP ;Check to prevent use of same case number/date pair ;ch
; both short and long case numbers will be checked for duplicates 091500
S RADTE99=$S('$D(RADTE):"",1:$E(RADTE,4,5)_$E(RADTE,6,7)_$E(RADTE,2,3))
;// begin RA5p214 //
;I '$D(^RADPT("AE",RAX)),'$D(^RADPT("ADC",RADTE99_"-"_RAX)) G DUPQ
I '$$DUPCNACC(RADTE99,RAX) G DUPQ
;// end RA5p214 //
; also check ADC xref while searching for next available number 08/15/00
; note2: even though the current available case number is being
; stored, the next free case number for future use will be
; found and stored later, see note1 above 091300
;// begin RA5p214 //
;F RAJ=(^RA(79.2,RATYPE,"CN")+1):1 I '$D(^RADPT("AE",RAJ)),'$D(^RADPT("ADC",RADTE99_"-"_RAJ)) S ^("CN")=RAJ_"^"_$P(^RA(79.2,RATYPE,"CN"),"^",2) S RAX=+^RA(79.2,RATYPE,"CN") Q
F RAJ=(^RA(79.2,RATYPE,"CN")+1):1 I '$$DUPCNACC(RADTE99,RAJ) D Q
.S ^RA(79.2,RATYPE,"CN")=RAJ_"^"_$P(^RA(79.2,RATYPE,"CN"),"^",2)
.S RAX=+$G(^RA(79.2,RATYPE,"CN")) ;Note: RAX assumes the value of the valid case #
.Q
;// begin RA5p214 //
DUPQ K RADTE99 Q
;
; the CAL section is called if :
; there isn't a ^RA(79.2,RATYPE,"CN")
; or today's date is after the date in ^RA(79.2,RATYPE,"CN") piece 2
; or ^RA(79.2,RATYPE,"CN") piece 1 is > 99999, this is
; checked in two places :
; before using this piece 1 as the next case number
; and after calculating future free case number
; or DUP section returns a case number > 99999
;
; the first calculation starts from today's date and finds the date
; for the next Saturday
; %Y=day of week, 6 being Saturday
;
; the second calculation starts from ^RADPT("AE",1 and finds the
; lowest n where ^RADPT("AE",n) doesn't exist anymore.
;
; then the results are used to replace ^RA(79.2,RATYPE,"CN")
; where
; piece 1 is the next free case number
; piece 2 is the date for next Saturday
; RATYPE is always 1 by design
;
CAL K RAXX S:$D(X) RAXX=X S RAX=DT F RAII=0:0 S X1=RAX,X2=1 D C^%DTC S RAX=X D H^%DTC Q:%Y=6
D YMD^%DTC F RAJ=1:1 I '$D(^RADPT("AE",RAJ)) S ^RA(79.2,RATYPE,"CN")=RAJ_"^"_X S:$D(RAXX) X=RAXX Q
K RAJ,RAXX,RAX,RAII Q
PROC(Y) Q $P($G(^RAMIS(71,+Y,0)),U)
ASET ; register extra cases for a exam/print set that has no VALID report yet
; there may be a stub report from imaging for this set
S RAREC="" ; prevent Q from deleting the exam at "DT" level
S (RAEXIT,RAQUIT,RASKIPIT,RACNICNT)=0 K ^TMP($J,"RAREG1")
N RAFIRST S RAFIRST=$O(^RADPT(RADFN,"DT",RADTI,"P",0)) Q:'RAFIRST
S RAOIFN=$P(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,0),"^",11) ;imagg order ien
N DIR
PS1 S DIR(0)="Y",DIR("A")="For "_RANME_"'s exam set -- register another descendent exam (Y/N)"
W ! D ^DIR Q:'Y
N RAPARENT S RAPARENT=1 D ORDER^RAREG2 ;preserve EXAM SET stored data
Q:RAQUIT ;6/18/96
K RAPRC S RAPARENT=1 D EXAMLOOP^RAREG2 ;prevent undef RAPROC in EXAMLOOP
; RACNI is set by edit tmpl that's used in EXAMLOOP^RAREG2
; quit if registration was incomplete <-- rareg2 deleted entire case
Q:'$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
S RAPROC=$P($G(^RAO(75.1,+$G(RAOIFN),0)),U,2) ;ien of parent procedure
; set value of MEMBER OF SET
; can't call memset^rareg2 to set MEMBER OF SET, due possiblity of
; orig. proc being a single procedure that got converted to printset
N RA25 S RA25=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,0)),U,25)
I RA25 N D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI,DR="25///"_RA25,DIE="^RADPT("_RADFN_",""DT"","_RADTI_",""P""," D ^DIE
G:RA25'=2 PS1
; combined report need more processing
G:'$G(RA17) PS1 G:'$D(^RARPT(+$G(RA17),0))#2 PS1
; since there's a stub rpt from imaging (RA17), set piece 17
D SET17^RAREG2(RADFN,RADTI,RACNI)
; copy over any dx/res/staff
D COPYFROM^RAREG2(RACNI)
; insert rec in 74.05
N RARPT,RARPTN,RA1,RAFDA,RAIEN,RAMSG,RAERR,RAXIT
S RARPT=RA17,RARPTN=$P(^RARPT(RARPT,0),U),RA1=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U)
P124 ;begin RA5P124 update
I RA1 D
.N RACCSTR S RACCSTR=$P(RARPTN,"-",1,($L(RARPTN,"-"))-1)_"-"_RA1
.D:($D(^RARPT("B",RACCSTR,RARPT))=0) INSERT^RARTE2
.Q
;end RA5P124 update
G PS1
;
CHKORDS(RARY) ;check all the RIS orders on file.
;If that order does not have a REQUEST STATUS of
;PENDING do not register & kill RARY(n). RA5P169
;Input: RARY by reference
; RARY(n) = RAOIFN (IEN file 75.1)
NEW N,RAOIFN S N=0
F S N=$O(RARY(N)) Q:N'>0 D
.S RAOIFN=RARY(N),RAOIFN(0)=$G(^RAO(75.1,RAOIFN,0))
.;If the REQUEST STATUS is not pending (piece five) -or-
.;the CPRS ORDER (#100) file pointer piece seven is
.;missing do not register the order.
.I $P(RAOIFN(0),U,5)'=5!($P(RAOIFN(0),U,7)="") K RARY(N)
.Q
Q
;
DUPCNACC(RADDMMYY,RAPCN) ;checks for duplicate case/exam accession/report accession numbers. Ski RA5P214
;input parameters
;RADDMMYY: dd/mm/yy date format. ex: 110320 (November 3rd 2020)
; RAPCN: the potential case number. between 1 - 99999 ex: 6743 (case: 6743)
;
;returns 0 if no duplicates are found, else 1
;define RALACC: temporary legacy accession number (the legacy form of the accession number will always be in "ADC")
;define RASSAN: site specific accession number (the report's "B" xref can be a legacy or a SSAN)
;RAMDIV is a package wide variable global in scope; used to get station # (RASTATION)
;*** station # does not always match file 4 IEN! ***
N RALACC,RASSAN,RASTATION S RALACC=RADDMMYY_"-"_RAPCN
S RASTATION=+$$STA^XUAF4($G(RAMDIV,0)),RASSAN=RASTATION_"-"_RALACC
Q:$D(^RADPT("AE",RAPCN))\10 1
Q:$D(^RADPT("ADC",RALACC))\10 1
;dual check on the report
Q:$D(^RARPT("B",RALACC))\10 1
Q:$D(^RARPT("B",RASSAN))\10 1
Q 0
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAREG1 10082 printed Nov 22, 2024@17:49:03 Page 2
RAREG1 ;HISC/CAH,FPT,DAD AISC/MJK,RMO - Register Patient ; May 31, 2024@16:27:41
+1 ;;5.0;Radiology/Nuclear Medicine;**7,21,93,137,144,124,153,169,214**;Mar 16, 1998;Build 1
+2 ; 07/15/2008 BAY/KAM rem call 249750 RA*5*93 Correct DIK Calls
+3 ;
+4 ;Tag^Routine IA# Usage Custodian Subscriber
+5 ;----------------------------------------------------------------
+6 ;$$STA^XUAF4 2171 Supported Kernel
+7 ;
ASKORD IF $DATA(RAVSTFLG)
IF $GET(YY)]""
IF $PIECE(YY,U,5)
DO ASET
GOTO PACS
+1 ; radparfl = 1 if user chose detail-to-parent conversion
+2 ; radparpr = ien of file 74 of parent proc to replace detail proc
+3 KILL RADPARPR,RADPARFL
+4 SET RAOLP=0
SET RAOVSTS="3;5;8"
WRITE !
DO ^RAORDS
if $DATA(RAOUT)
GOTO Q1
if $DATA(RAORDS)
GOTO EXAM
+5 SET RARD("A")="Do you want to Request an Exam for "_RANME_"? "
SET RARD(0)="S"
SET RARD(1)="Yes^enter a request."
SET RARD(2)="No^not enter a request."
SET RARD("B")=2
DO SET^RARD
KILL RARD
if $EXTRACT(X)'="Y"
GOTO Q1
+6 WRITE !!?3,"...requesting an exam for ",RANME,"...",!
DO ^RAORD1
+7 ;quit if the RAORDS array does not exist (no pending RIS orders filed for this event)
+8 ;RIS orders will exist but will they be ibn a 'canceled' REQUEST STATUS?
+9 ;pass in RAORDS array
DO CHKORDS(.RAORDS)
+10 if ($DATA(RAORDS)\10)=0
QUIT
+11 ;
EXAM ;
+1 ; block mixture of single proc with parent procedures
+2 NEW RA6,RA7,RA8
SET RA6=""
SET RA7=0
SET RA8=0
+3 FOR
SET RA6=$ORDER(RAORDS(RA6))
if 'RA6
QUIT
if $PIECE($GET(^RAMIS(71,$PIECE(^RAO(75.1,+RAORDS(RA6),0),U,2),0)),U,6)="P"
SET RA7=1
if $PIECE($GET(^RAMIS(71,$PIECE(^RAO(75.1,+RAORDS(RA6),0),U,2),0)),U,6)'="P"
SET RA8=1
+4 IF RA7
IF RA8
WRITE !!?7,$CHAR(7),"You may not register a mixture of single and parent procedures.",!
GOTO Q1
+5 ;
+6 ; process detail-to-parent
IF $GET(RADPARFL)
Begin DoDot:1
+7 DO PSETPNT^RAREG4
+8 QUIT
End DoDot:1
if Y<1
GOTO Q1
+9 SET RAPARENT=+$PIECE($GET(^RADPT(RADFN,"DT",RADTI,0)),U,5)
+10 KILL ^TMP($JOB,"RAREG1")
SET (RAEXIT,RAQUIT,RASKIPIT,RACNICNT)=0
+11 DO RSBIT^RAREG3
+12 FOR RAOLP=1:1
SET RAOIFN=$GET(RAORDS(RAOLP))
if 'RAOIFN!RAEXIT!RAQUIT
QUIT
Begin DoDot:1
+13 DO PROCESS^RAREG4
+14 QUIT
End DoDot:1
+15 IF RAEXIT
IF RAPARENT
DO EXAMDEL^RAREG2
+16 IF $DATA(^TMP($JOB,"RAREG1"))
DO UOSM^RAREG2
PACS IF $DATA(^TMP($JOB,"RAREG1"))
SET RACNT=0
FOR
SET RACNT=$ORDER(^TMP($JOB,"RAREG1",RACNT))
if 'RACNT
QUIT
Begin DoDot:1
+1 SET RAREGTMP=$GET(^TMP($JOB,"RAREG1",RACNT))
SET RADFN=$PIECE(RAREGTMP,U,1)
SET RADTI=$PIECE(RAREGTMP,U,2)
SET RACNI=$PIECE(RAREGTMP,U,3)
+2 DO REG^RAHLRPC
+3 QUIT
End DoDot:1
+4 KILL RAREGTMP
+5 ; ck for dupl procs in outstndg orders
if $DATA(RADPARFL)
DO CKDUPORD^RAREG2
Q IF '$DATA(RAREC)
WRITE !!?3,$CHAR(7),"No exams entered for this visit. Must delete..."
SET DA(1)=RADFN
SET DA=RADTI
SET DIK="^RADPT("_DA(1)_",""DT"","
DO ^DIK
WRITE "...deletion complete!"
KILL RAPX
+1 ;print request when exam is registered - P137 /KLM
DO PRNRQ^RAREG3
+2 DO LABEL^RAREG3
Q1 DO Q4^RAREG4
+1 GOTO PAT^RAREG
+2 ;
+3 ;CN entry point is called every time a new case number is assigned.
+4 ;The next available CN and last date CN's were "recycled" is stored in
+5 ;^RA(79.2,1,"CN")=Next availabe CN ^ date last recycled.
+6 ;This routine uses the next available CN unless it has been used for
+7 ;the same exam date before (DUP checks for duplicate case/date pair).
+8 ;Then the next available CN is calculated and written to the first
+9 ;piece of ^RA(79.2,1,"CN"). The node is locked during this transaction.
CN ;VARIABLES RATYPE,RADT AND RASET MUST EXIST AT THIS POINT
+1 ; 11/05/2008 BAY/KAM rem call 273496 RA*5*93 Add lock timeout to next line
+2 LOCK +^RA(79.2,RATYPE,"CN"):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
if '$DATA(^RA(79.2,RATYPE,"CN"))
DO CAL
if DT>$PIECE(^("CN"),"^",2)
DO CAL
if +^("CN")>99999
DO CAL
SET RAX=+^RA(79.2,RATYPE,"CN")
DO DUP
+3 ; need recalculate if DUP returns an over 99999 value
+4 IF RAX>99999
DO CAL
SET RAX=+^RA(79.2,RATYPE,"CN")
DO DUP
+5 IF 'RASET
SET X=RAX
GOTO CNQ
+6 IF $DATA(X)
IF X'="N"
IF X'=RAX
WRITE !!,$CHAR(7),"New case number must be equal to '",RAX,"'. OK? YES// "
READ RANS:DTIME
KILL X
IF RANS["N"!(RANS["n")!('$TEST)
GOTO CNQ
+7 SET X=RAX
+8 ; get next available short case number for future registration
+9 ; re-set "CN" node if future short case number >99999
+10 ; NOTE1: find and store next free case number for future use 091300
+11 FOR RAJ=(^RA(79.2,RATYPE,"CN")+1):1
IF '$DATA(^RADPT("AE",RAJ))
SET ^("CN")=RAJ_"^"_$PIECE(^RA(79.2,RATYPE,"CN"),"^",2)
QUIT
+12 ; if the next free case no. for future use is >99999, need recalculate
+13 IF +^RA(79.2,RATYPE,"CN")>99999
DO CAL
CNQ LOCK -^RA(79.2,RATYPE,"CN")
+1 IF $DATA(X)
IF X>99999
WRITE !!?3,$CHAR(7),"You have reached the maximum limit for case numbers (99,999).",!?3,"You must first complete/purge your old exams before you can proceed."
KILL X
+2 KILL RAJ,RATYPE,RASET,RAX,RANS,RADT
QUIT
DUP ;Check to prevent use of same case number/date pair ;ch
+1 ; both short and long case numbers will be checked for duplicates 091500
+2 SET RADTE99=$SELECT('$DATA(RADTE):"",1:$EXTRACT(RADTE,4,5)_$EXTRACT(RADTE,6,7)_$EXTRACT(RADTE,2,3))
+3 ;// begin RA5p214 //
+4 ;I '$D(^RADPT("AE",RAX)),'$D(^RADPT("ADC",RADTE99_"-"_RAX)) G DUPQ
+5 IF '$$DUPCNACC(RADTE99,RAX)
GOTO DUPQ
+6 ;// end RA5p214 //
+7 ; also check ADC xref while searching for next available number 08/15/00
+8 ; note2: even though the current available case number is being
+9 ; stored, the next free case number for future use will be
+10 ; found and stored later, see note1 above 091300
+11 ;// begin RA5p214 //
+12 ;F RAJ=(^RA(79.2,RATYPE,"CN")+1):1 I '$D(^RADPT("AE",RAJ)),'$D(^RADPT("ADC",RADTE99_"-"_RAJ)) S ^("CN")=RAJ_"^"_$P(^RA(79.2,RATYPE,"CN"),"^",2) S RAX=+^RA(79.2,RATYPE,"CN") Q
+13 FOR RAJ=(^RA(79.2,RATYPE,"CN")+1):1
IF '$$DUPCNACC(RADTE99,RAJ)
Begin DoDot:1
+14 SET ^RA(79.2,RATYPE,"CN")=RAJ_"^"_$PIECE(^RA(79.2,RATYPE,"CN"),"^",2)
+15 ;Note: RAX assumes the value of the valid case #
SET RAX=+$GET(^RA(79.2,RATYPE,"CN"))
+16 QUIT
End DoDot:1
QUIT
+17 ;// begin RA5p214 //
DUPQ KILL RADTE99
QUIT
+1 ;
+2 ; the CAL section is called if :
+3 ; there isn't a ^RA(79.2,RATYPE,"CN")
+4 ; or today's date is after the date in ^RA(79.2,RATYPE,"CN") piece 2
+5 ; or ^RA(79.2,RATYPE,"CN") piece 1 is > 99999, this is
+6 ; checked in two places :
+7 ; before using this piece 1 as the next case number
+8 ; and after calculating future free case number
+9 ; or DUP section returns a case number > 99999
+10 ;
+11 ; the first calculation starts from today's date and finds the date
+12 ; for the next Saturday
+13 ; %Y=day of week, 6 being Saturday
+14 ;
+15 ; the second calculation starts from ^RADPT("AE",1 and finds the
+16 ; lowest n where ^RADPT("AE",n) doesn't exist anymore.
+17 ;
+18 ; then the results are used to replace ^RA(79.2,RATYPE,"CN")
+19 ; where
+20 ; piece 1 is the next free case number
+21 ; piece 2 is the date for next Saturday
+22 ; RATYPE is always 1 by design
+23 ;
CAL KILL RAXX
if $DATA(X)
SET RAXX=X
SET RAX=DT
FOR RAII=0:0
SET X1=RAX
SET X2=1
DO C^%DTC
SET RAX=X
DO H^%DTC
if %Y=6
QUIT
+1 DO YMD^%DTC
FOR RAJ=1:1
IF '$DATA(^RADPT("AE",RAJ))
SET ^RA(79.2,RATYPE,"CN")=RAJ_"^"_X
if $DATA(RAXX)
SET X=RAXX
QUIT
+2 KILL RAJ,RAXX,RAX,RAII
QUIT
PROC(Y) QUIT $PIECE($GET(^RAMIS(71,+Y,0)),U)
ASET ; register extra cases for a exam/print set that has no VALID report yet
+1 ; there may be a stub report from imaging for this set
+2 ; prevent Q from deleting the exam at "DT" level
SET RAREC=""
+3 SET (RAEXIT,RAQUIT,RASKIPIT,RACNICNT)=0
KILL ^TMP($JOB,"RAREG1")
+4 NEW RAFIRST
SET RAFIRST=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",0))
if 'RAFIRST
QUIT
+5 ;imagg order ien
SET RAOIFN=$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,0),"^",11)
+6 NEW DIR
PS1 SET DIR(0)="Y"
SET DIR("A")="For "_RANME_"'s exam set -- register another descendent exam (Y/N)"
+1 WRITE !
DO ^DIR
if 'Y
QUIT
+2 ;preserve EXAM SET stored data
NEW RAPARENT
SET RAPARENT=1
DO ORDER^RAREG2
+3 ;6/18/96
if RAQUIT
QUIT
+4 ;prevent undef RAPROC in EXAMLOOP
KILL RAPRC
SET RAPARENT=1
DO EXAMLOOP^RAREG2
+5 ; RACNI is set by edit tmpl that's used in EXAMLOOP^RAREG2
+6 ; quit if registration was incomplete <-- rareg2 deleted entire case
+7 if '$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
QUIT
+8 ;ien of parent procedure
SET RAPROC=$PIECE($GET(^RAO(75.1,+$GET(RAOIFN),0)),U,2)
+9 ; set value of MEMBER OF SET
+10 ; can't call memset^rareg2 to set MEMBER OF SET, due possiblity of
+11 ; orig. proc being a single procedure that got converted to printset
+12 NEW RA25
SET RA25=$PIECE($GET(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,0)),U,25)
+13 IF RA25
NEW D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
SET DA(2)=RADFN
SET DA(1)=RADTI
SET DA=RACNI
SET DR="25///"_RA25
SET DIE="^RADPT("_RADFN_",""DT"","_RADTI_",""P"","
DO ^DIE
+14 if RA25'=2
GOTO PS1
+15 ; combined report need more processing
+16 if '$GET(RA17)
GOTO PS1
if '$DATA(^RARPT(+$GET(RA17),0))#2
GOTO PS1
+17 ; since there's a stub rpt from imaging (RA17), set piece 17
+18 DO SET17^RAREG2(RADFN,RADTI,RACNI)
+19 ; copy over any dx/res/staff
+20 DO COPYFROM^RAREG2(RACNI)
+21 ; insert rec in 74.05
+22 NEW RARPT,RARPTN,RA1,RAFDA,RAIEN,RAMSG,RAERR,RAXIT
+23 SET RARPT=RA17
SET RARPTN=$PIECE(^RARPT(RARPT,0),U)
SET RA1=$PIECE($GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U)
P124 ;begin RA5P124 update
+1 IF RA1
Begin DoDot:1
+2 NEW RACCSTR
SET RACCSTR=$PIECE(RARPTN,"-",1,($LENGTH(RARPTN,"-"))-1)_"-"_RA1
+3 if ($DATA(^RARPT("B",RACCSTR,RARPT))=0)
DO INSERT^RARTE2
+4 QUIT
End DoDot:1
+5 ;end RA5P124 update
+6 GOTO PS1
+7 ;
CHKORDS(RARY) ;check all the RIS orders on file.
+1 ;If that order does not have a REQUEST STATUS of
+2 ;PENDING do not register & kill RARY(n). RA5P169
+3 ;Input: RARY by reference
+4 ; RARY(n) = RAOIFN (IEN file 75.1)
+5 NEW N,RAOIFN
SET N=0
+6 FOR
SET N=$ORDER(RARY(N))
if N'>0
QUIT
Begin DoDot:1
+7 SET RAOIFN=RARY(N)
SET RAOIFN(0)=$GET(^RAO(75.1,RAOIFN,0))
+8 ;If the REQUEST STATUS is not pending (piece five) -or-
+9 ;the CPRS ORDER (#100) file pointer piece seven is
+10 ;missing do not register the order.
+11 IF $PIECE(RAOIFN(0),U,5)'=5!($PIECE(RAOIFN(0),U,7)="")
KILL RARY(N)
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
DUPCNACC(RADDMMYY,RAPCN) ;checks for duplicate case/exam accession/report accession numbers. Ski RA5P214
+1 ;input parameters
+2 ;RADDMMYY: dd/mm/yy date format. ex: 110320 (November 3rd 2020)
+3 ; RAPCN: the potential case number. between 1 - 99999 ex: 6743 (case: 6743)
+4 ;
+5 ;returns 0 if no duplicates are found, else 1
+6 ;define RALACC: temporary legacy accession number (the legacy form of the accession number will always be in "ADC")
+7 ;define RASSAN: site specific accession number (the report's "B" xref can be a legacy or a SSAN)
+8 ;RAMDIV is a package wide variable global in scope; used to get station # (RASTATION)
+9 ;*** station # does not always match file 4 IEN! ***
+10 NEW RALACC,RASSAN,RASTATION
SET RALACC=RADDMMYY_"-"_RAPCN
+11 SET RASTATION=+$$STA^XUAF4($GET(RAMDIV,0))
SET RASSAN=RASTATION_"-"_RALACC
+12 if $DATA(^RADPT("AE",RAPCN))\10
QUIT 1
+13 if $DATA(^RADPT("ADC",RALACC))\10
QUIT 1
+14 ;dual check on the report
+15 if $DATA(^RARPT("B",RALACC))\10
QUIT 1
+16 if $DATA(^RARPT("B",RASSAN))\10
QUIT 1
+17 QUIT 0
+18 ;
