RAREG2 ;HISC/CAH,FPT,DAD,SS AISC/MJK,RMO-Register Patient ; 06 Oct 2013 11:04 AM
;;5.0;Radiology/Nuclear Medicine;**13,18,93,99,1003,1005**;Nov 01, 2010;Build 13
;last modif. JULY 5,00 by SS
; 07/15/2008 BAY/KAM rem call 249750 RA*5*93 Correct DIK Calls
; 06/04/09 rvd - display pregnancy screen and pregnancy screen comment only in Add Exams to Last visit option.
; Supported IA #2053 reference to ^DIE
; Supported IA #10013 reference to ^DIK
ORDER ; Get data from ordered procedure for registration
K RACLNC,RALIFN,RALOC,RAPIFN,RAPRC,RARDTE,RARSH,RASHA
S Y=^RAO(75.1,+RAOIFN,0),RAPRC=$S($D(^RAMIS(71,+$P(Y,"^",2),0)):$P(^(0),"^"),1:"") S:$D(RADPARFL) RAPRC=RADPARPR ;may not need to redefine raprc ?
S RACAT=$S('$D(RAWARD):$P($P(^DD(75.1,4,0),$P(Y,"^",4)_":",2),";"),1:RACAT)
D SL^RAREG3 Q:RAQUIT
S:"CS"[$E(RACAT)&($D(^DIC(34,+$P(Y,"^",9),0))) RASHA=$P(^(0),"^") S:"R"[$E(RACAT)&($D(^RAO(75.1,+RAOIFN,"R"))) RARSH=^("R")
S:$D(^VA(200,+$P(Y,"^",14),0)) RAPIFN=+$P(Y,"^",14) S:$P(Y,"^",21) RARDTE=$P(Y,"^",21) S:$D(^SC(+$P(Y,"^",22),0)) RALIFN=+$P(Y,"^",22)
I '$D(RAWARD),$D(RALIFN),$P(^SC(RALIFN,0),"^",3)="C" S RALOC=$P(^(0),"^") S RACLNC=$S('$D(^("SL")):RALOC,$D(^SC(+$P(^("SL"),"^",5),0)):$P(^(0),"^"),1:RALOC)
;check nodes ahead 6/18/96
N RAAHEAD
S RAAHEAD=$O(^RADPT(RADFN,"DT","B",RADTE))
I RAAHEAD[RADTE W $C(7),!!?5,"Someone else has already started editing a record for this",!?5,"patient at this time, please try a few minutes later." S RAQUIT=1 R !!,"Press RETURN to continue :",RAAHEAD:DTIME
Q
EXAMLOOP ; register the exam
N REM ;this is used by the edit template
;P99; keep previous pregnancy screen data before adding new exam
;
;IHS/BJI/DAY - Patch 1005 - Gender Fix
;I $D(RAOPT("ADDEXAM")),$$PTSEX^RAUTL8(RADFN)="F" S RA703DAT=$$PRCEXA^RAUTL8(RADFN) ;ra703dat holds the previous entry
I $D(RAOPT("ADDEXAM")),$$PTSEX^RAUTL8(RADFN)'="M" S RA703DAT=$$PRCEXA^RAUTL8(RADFN) ;ra703dat holds the previous entry
;
S DA=RADFN,RACN="N",DIE("NO^")="OUTOK",DR="[RA REGISTER]",DIE="^RADPT(" D ^DIE K DIE("NO^"),DE,DQ
;
;IHS/BJI/DAY - Patch 1005 - Default Pregnancy Status to Unknown
;Controlled by site parameter
I +$G(RAMDIV),$P($G(^RA(79,+RAMDIV,9999999)),"^",2)=1 D
.I $G(RADFN)="" Q
.I $G(RADTI)="" Q
.I $G(RACNI)="" Q
.I $$PTSEX^RAUTL8(RADFN)="M" Q
.I $$PTAGE^RAUTL8(RADFN,"")>55 Q
.I $$PTAGE^RAUTL8(RADFN,"")<12 Q
.I '$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) Q
.I $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,32)]"" Q
.S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,32)="u"
;End Patch
;
K RAPOP,RAFM,RAFM1,RAI,RAMOD,RASTI,RACMTHOD,RANMFLG,RAIEN702 ;moved from edit template
S RACNICNT=RACNICNT+1
S ^TMP($J,"RAREG1",RACNICNT)=RADFN_U_RADTI_U_RACNI_U_RAOIFN
I '$D(RAFIN) D Q
. W !?3,$C(7),"Exam entry not complete. Must delete..."
. S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI
. ; Modified the next line for rem call 249750
. S DIK="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," D ^DIK
. K ^TMP($J,"RAREG1",RACNICNT)
. K RAPX ; added in RA*5*13 to stop labels & flash cards in RAREG1
. Q
;start of p99, display and SET pregnancy screen and pregnancy screen comment
;value defaulted from previous case exam (regardless of case exam status)
;
;IHS/BJI/DAY - Patch 1005 - Gender Fix
;I $D(RAOPT("ADDEXAM")),$$PTSEX^RAUTL8(RADFN)="F" D
I $D(RAOPT("ADDEXAM")),$$PTSEX^RAUTL8(RADFN)'="M" D
.;
.Q:'$D(RA703DAT)
.N RA3,RADTIEN,RACNIEN,RAPCOMM
.S RADTIEN=$P(RA703DAT,U),RACNIEN=$P(RA703DAT,U,2)
.S RA3=$G(^RADPT(RADFN,"DT",RADTIEN,"P",RACNIEN,0))
.S RAPCOMM=$G(^RADPT(RADFN,"DT",RADTIEN,"P",RACNIEN,"PCOMM"))
.W:$P(RA3,U,32)'="" !," PREGNANCY SCREEN: ",$S($P(RA3,U,32)="y":"Patient answered yes",$P(RA3,U,32)="n":"Patient answered no",$P(RA3,U,32)="u":"Patient is unable to answer or is unsure",1:"")
.W:$P(RA3,U,32)'="n"&$L(RAPCOMM) !," PREGNANCY SCREEN COMMENT: ",RAPCOMM
.N RAPTAGE S RAPTAGE=$$PTAGE^RAUTL8(RADFN,"")
.Q:RAPTAGE<12!(RAPTAGE>55)
.I $P(RA3,U,32)'="" D
..N RAFDA
..S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",32)=$P(RA3,U,32)
..D FILE^DIE("","RAFDA")
.I $D(^RADPT(RADFN,"DT",RADTIEN,"P",RACNIEN,"PCOMM")) D
..N RAFDA
..S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",80)=^RADPT(RADFN,"DT",RADTIEN,"P",RACNIEN,"PCOMM")
..D FILE^DIE("","RAFDA")
;end of p99
S RAPARENT=$S($G(RAPARENT):RAPARENT,$P($G(^RAMIS(71,RAPROC,0)),U,6)="P":1,1:+$G(RAPARENT))
I $D(^RAO(75.1,+RAOIFN,"H")) S:$D(^("H",0)) ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0)=^(0) F I=1:1 Q:'$D(^RAO(75.1,+RAOIFN,"H",I,0)) S ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",I,0)=^(0)
;IHS/BJI/DAY - Patch 1003 - Continue Chris Saddler 2005 Patch
;Add set of Exam Date for PCC
S ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCC")=$P(RADTE,".")
;End Patch
S ^DISV($S($D(DUZ)#2:DUZ,1:0),"RA","CASE #")=RADFN_"^"_RADTI_"^"_RACNI,RAREC=""
S:$D(RADPARFL) ^TMP($J,"PRO-REG",RAPROCI,RAOIFN)=""
K RAFIN,DR,RA703DAT
K RACLNC,RALIFN,RALOC,RAOSTS,RAPHY,RAPRC,RARDTE,RARSH,RASHA
Q
EXAMDEL ; Delete examset if incomplete
W !!?3,$C(7),"Exam entry not complete. Must delete all descendent exams..."
S RATMP=0
F S RATMP=$O(^TMP($J,"RAREG1",RATMP)) Q:RATMP'>0 D
. S RA=^TMP($J,"RAREG1",RATMP)
. S RAOIFN=$P(RA,U,4),(RADFN,DA(2))=$P(RA,U)
. S (RADTI,DA(1))=$P(RA,U,2),(RACNI,DA)=$P(RA,U,3)
. ; Modified the next line for rem call 249750
. S DIK="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," D ^DIK
. K ^TMP($J,"RAREG1",RATMP),RAPX(RATMP)
. K DIE,DR S DIE="^RAO(75.1,",DA=RAOIFN,DR="5///5" D ^DIE K DIE,DR
. Q
W !?3,"Deletion complete!",!
Q
XTRADESC ; Ask extra descendent procedures for a parent
N RASKIPIT S RASKIPIT=0
F D Q:RASKIPIT!RAEXIT!RAQUIT
. N DIR S DIR(0)="Y"
. S DIR("A")="Register another descendent exam for "_RANME_" (Y/N)"
. W ! D ^DIR
. S RAEXIT=$S($D(DTOUT)!$D(DUOUT):1,1:0),RASKIPIT='Y
. I RASKIPIT!RAEXIT Q
. D ORDER K RAPRC Q:RAQUIT
. D EXAMLOOP,MEMSET(RADFN,RADTI,RACNI)
. Q
Q
EXAMSET ; Set the EXAM SET field if a parent is registered
N DA,DIE,DR,Y
S DIE="^RADPT("_RADFN_",""DT"","
S DA(1)=RADFN,DA=RADTI
S DR="5///^S X=$S($G(RAPARENT):''RAPARENT,1:""@"")"
D ^DIE
Q
MEMSET(RAX,RAY,RAZ) ; Set 'MEMBER OF SET' field on the exam node
; if the procedure is a descendant procedure.
; Var List: RAX <-> RADFN : RAY <-> RADTI : RAZ <-> RACNI
Q:$G(^RADPT(RAX,"DT",RAY,"P",RAZ,0))']""
N D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
S DIE="^RADPT("_RAX_",""DT"","_RAY_",""P"","
S DA(2)=RAX,DA(1)=RAY,DA=RAZ,DR="25///"_$S($P($G(^RAMIS(71,+RAPROC,0)),"^",18)="Y":2,1:1) D ^DIE ;2=combined report, 1=separate reports
Q
SET17(RAX,RAY,RAZ) ; Set piece 17 on exam node
Q:$G(^RADPT(RAX,"DT",RAY,"P",RAZ,0))']""
N D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
S DIE="^RADPT("_RAX_",""DT"","_RAY_",""P"","
S DA(2)=RAX,DA(1)=RAY,DA=RAZ,DR="17///"_RA17 D ^DIE
Q
UOSM ; called from RAREG1
; update order status and send OE v3.0 message
; This code will $O through the ^TMP($J,"RAREG1" global and make
; just one call per order/request number to ^RAORDU to update the
; status in File 75.1. One call to ^RAORDU per order/request number
; means only one HL7 type message per order/request will be sent to
; OE v3.0.
;
Q:'$D(^TMP($J,"RAREG1"))
N RACNT,RAORDNUM,RATMPNDE
S RACNT=0
F S RACNT=$O(^TMP($J,"RAREG1",RACNT)) Q:RACNT'>0 D
.S RATMPNDE=$G(^TMP($J,"RAREG1",RACNT))
.S RAOIFN=$P(RATMPNDE,U,4) I RAOIFN D
..Q:$D(RAORDNUM(RAOIFN))
..S RAPROC=$P(^RAO(75.1,+RAOIFN,0),U,2)
..N RA18PCHG S RA18PCHG=$$EN1^RAO7XX(RAOIFN) ;P18 - if the proc changed, sends XX mess, sets RA18PCHG=1 for RAORDU
..S RAOSTS=6 D ^RAORDU
..S RAORDNUM(RAOIFN)=""
..Q
.Q
Q
CKDUPORD ; ck for dupl procedures in outstanding orders
S RA6="",RA8=0
CKD1 S RA6=$O(^TMP($J,"PRO-REG",RA6)) Q:'RA6
S RA7=$O(^TMP($J,"PRO-REG",RA6,0)) G:'RA7 CKD1
K ^TMP($J,"PRO-ORD",RA6,RA7) ; kill hook for order of regist'd proc
G:'$O(^TMP($J,"PRO-ORD",RA6,0)) CKD1
W:'RA8 !!?5,"Of the procedures you just registered,",!?5,"the following procedure(s) are still in outstanding order(s) :",$C(7),!
S RA8=1
S RA7=""
F S RA7=$O(^TMP($J,"PRO-ORD",RA6,RA7)) Q:'RA7 W !?5,$P(^RAMIS(71,RA6,0),U) W:^TMP($J,"PRO-ORD",RA6,RA7)="DESC" ?35,"(parent=",$P(^RAMIS(71,$P($G(^RAO(75.1,RA7,0)),U,2),0),U),")"
G CKD1
COPYFROM(RAZ) ;called by RAREG1 if add exam shd copy dx/staff/resident
;RAZ is "P"-node's ien of newly added case of set
Q:'$D(RAFIRST)#2 ;RAFIRST is "P"-node's ien of first case of set
Q:$G(^RADPT(RADFN,"DT",RADTI,"P",RAZ,0))']""
Q:$G(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,0))']""
N RA,RA2,RA3,RA5 S RA5=0
; RA is a dummy var
; RA2 is used by data server call in RARTE2
; RA3 is used by COPYn^RARTE2 as a dummy var
; RA5=1 if any data got copied over to the new case
N RA1PR,RA1PS ; prim res/staff
N RA1SR,RA1SS ; sec res/staff arrays
N RA1PD,RA1SD ; prim diag, then sec diags arrays
N RAFDA,RAIEN,RAMSG,RAXIT
S RAXIT=0
S RA2=RAZ_","_RADTI_","_RADFN
; get data from first case of set
S RA1PR=$P(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,0),U,12),RA1PS=$P(^(0),U,15),RA1PD=$P(^(0),U,13)
I $D(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"SRR",0)) S RA=0 F S RA=$O(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"SRR",RA)) Q:+RA'=RA S RA1SR(RA)=+(^(RA,0))
I $D(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"SSR",0)) S RA=0 F S RA=$O(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"SSR",RA)) Q:+RA'=RA S RA1SS(RA)=+(^(RA,0))
I $D(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"DX",0)) S RA=0 F S RA=$O(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"DX",RA)) Q:+RA'=RA S RA1SD(RA)=+(^(RA,0))
; copy data from first case of set to new case
S:RA1PR $P(^RADPT(RADFN,"DT",RADTI,"P",RAZ,0),U,12)=RA1PR,RA5=1
S:RA1PS $P(^RADPT(RADFN,"DT",RADTI,"P",RAZ,0),U,15)=RA1PS,RA5=1
S:RA1PD $P(^RADPT(RADFN,"DT",RADTI,"P",RAZ,0),U,13)=RA1PD,RA5=1
I $O(RA1SR("")) S RA3="" D COPY3^RARTE2 S RA5=1
I $O(RA1SS("")) S RA3="" D COPY4^RARTE2 S RA5=1
I $O(RA1SD("")) S RA3="" D COPY5^RARTE2 S RA5=1
Q:'RA5
; set xref for this new case only
S DIK="^RADPT("_RADFN_",""DT"","_RADTI_",""P"","
S DA(2)=RADFN,DA(1)=RADTI,DA=RAZ
D IX1^DIK
Q
RAREG2 ;HISC/CAH,FPT,DAD,SS AISC/MJK,RMO-Register Patient ; 06 Oct 2013 11:04 AM
+1 ;;5.0;Radiology/Nuclear Medicine;**13,18,93,99,1003,1005**;Nov 01, 2010;Build 13
+2 ;last modif. JULY 5,00 by SS
+3 ; 07/15/2008 BAY/KAM rem call 249750 RA*5*93 Correct DIK Calls
+4 ; 06/04/09 rvd - display pregnancy screen and pregnancy screen comment only in Add Exams to Last visit option.
+5 ; Supported IA #2053 reference to ^DIE
+6 ; Supported IA #10013 reference to ^DIK
ORDER ; Get data from ordered procedure for registration
+1 KILL RACLNC,RALIFN,RALOC,RAPIFN,RAPRC,RARDTE,RARSH,RASHA
+2 ;may not need to redefine raprc ?
SET Y=^RAO(75.1,+RAOIFN,0)
SET RAPRC=$SELECT($DATA(^RAMIS(71,+$PIECE(Y,"^",2),0)):$PIECE(^(0),"^"),1:"")
IF $DATA(RADPARFL)
SET RAPRC=RADPARPR
+3 SET RACAT=$SELECT('$DATA(RAWARD):$PIECE($PIECE(^DD(75.1,4,0),$PIECE(Y,"^",4)_":",2),";"),1:RACAT)
+4 DO SL^RAREG3
IF RAQUIT
QUIT
+5 IF "CS"[$EXTRACT(RACAT)&($DATA(^DIC(34,+$PIECE(Y,"^",9),0)))
SET RASHA=$PIECE(^(0),"^")
IF "R"[$EXTRACT(RACAT)&($DATA(^RAO(75.1,+RAOIFN,"R")))
SET RARSH=^("R")
+6 IF $DATA(^VA(200,+$PIECE(Y,"^",14),0))
SET RAPIFN=+$PIECE(Y,"^",14)
IF $PIECE(Y,"^",21)
SET RARDTE=$PIECE(Y,"^",21)
IF $DATA(^SC(+$PIECE(Y,"^",22),0))
SET RALIFN=+$PIECE(Y,"^",22)
+7 IF '$DATA(RAWARD)
IF $DATA(RALIFN)
IF $PIECE(^SC(RALIFN,0),"^",3)="C"
SET RALOC=$PIECE(^(0),"^")
SET RACLNC=$SELECT('$DATA(^("SL")):RALOC,$DATA(^SC(+$PIECE(^("SL"),"^",5),0)):$PIECE(^(0),"^"),1:RALOC)
+8 ;check nodes ahead 6/18/96
+9 NEW RAAHEAD
+10 SET RAAHEAD=$ORDER(^RADPT(RADFN,"DT","B",RADTE))
+11 IF RAAHEAD[RADTE
WRITE $CHAR(7),!!?5,"Someone else has already started editing a record for this",!?5,"patient at this time, please try a few minutes later."
SET RAQUIT=1
READ !!,"Press RETURN to continue :",RAAHEAD:DTIME
+12 QUIT
EXAMLOOP ; register the exam
+1 ;this is used by the edit template
NEW REM
+2 ;P99; keep previous pregnancy screen data before adding new exam
+3 ;
+4 ;IHS/BJI/DAY - Patch 1005 - Gender Fix
+5 ;I $D(RAOPT("ADDEXAM")),$$PTSEX^RAUTL8(RADFN)="F" S RA703DAT=$$PRCEXA^RAUTL8(RADFN) ;ra703dat holds the previous entry
+6 ;ra703dat holds the previous entry
IF $DATA(RAOPT("ADDEXAM"))
IF $$PTSEX^RAUTL8(RADFN)'="M"
SET RA703DAT=$$PRCEXA^RAUTL8(RADFN)
+7 ;
+8 SET DA=RADFN
SET RACN="N"
SET DIE("NO^")="OUTOK"
SET DR="[RA REGISTER]"
SET DIE="^RADPT("
DO ^DIE
KILL DIE("NO^"),DE,DQ
+9 ;
+10 ;IHS/BJI/DAY - Patch 1005 - Default Pregnancy Status to Unknown
+11 ;Controlled by site parameter
+12 IF +$GET(RAMDIV)
IF $PIECE($GET(^RA(79,+RAMDIV,9999999)),"^",2)=1
Begin DoDot:1
+13 IF $GET(RADFN)=""
QUIT
+14 IF $GET(RADTI)=""
QUIT
+15 IF $GET(RACNI)=""
QUIT
+16 IF $$PTSEX^RAUTL8(RADFN)="M"
QUIT
+17 IF $$PTAGE^RAUTL8(RADFN,"")>55
QUIT
+18 IF $$PTAGE^RAUTL8(RADFN,"")<12
QUIT
+19 IF '$DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
QUIT
+20 IF $PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,32)]""
QUIT
+21 SET $PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,32)="u"
End DoDot:1
+22 ;End Patch
+23 ;
+24 ;moved from edit template
KILL RAPOP,RAFM,RAFM1,RAI,RAMOD,RASTI,RACMTHOD,RANMFLG,RAIEN702
+25 SET RACNICNT=RACNICNT+1
+26 SET ^TMP($JOB,"RAREG1",RACNICNT)=RADFN_U_RADTI_U_RACNI_U_RAOIFN
+27 IF '$DATA(RAFIN)
Begin DoDot:1
+28 WRITE !?3,$CHAR(7),"Exam entry not complete. Must delete..."
+29 SET DA(2)=RADFN
SET DA(1)=RADTI
SET DA=RACNI
+30 ; Modified the next line for rem call 249750
+31 SET DIK="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
DO ^DIK
+32 KILL ^TMP($JOB,"RAREG1",RACNICNT)
+33 ; added in RA*5*13 to stop labels & flash cards in RAREG1
KILL RAPX
+34 QUIT
End DoDot:1
QUIT
+35 ;start of p99, display and SET pregnancy screen and pregnancy screen comment
+36 ;value defaulted from previous case exam (regardless of case exam status)
+37 ;
+38 ;IHS/BJI/DAY - Patch 1005 - Gender Fix
+39 ;I $D(RAOPT("ADDEXAM")),$$PTSEX^RAUTL8(RADFN)="F" D
+40 IF $DATA(RAOPT("ADDEXAM"))
IF $$PTSEX^RAUTL8(RADFN)'="M"
Begin DoDot:1
+41 ;
+42 IF '$DATA(RA703DAT)
QUIT
+43 NEW RA3,RADTIEN,RACNIEN,RAPCOMM
+44 SET RADTIEN=$PIECE(RA703DAT,U)
SET RACNIEN=$PIECE(RA703DAT,U,2)
+45 SET RA3=$GET(^RADPT(RADFN,"DT",RADTIEN,"P",RACNIEN,0))
+46 SET RAPCOMM=$GET(^RADPT(RADFN,"DT",RADTIEN,"P",RACNIEN,"PCOMM"))
+47 IF $PIECE(RA3,U,32)'=""
WRITE !," PREGNANCY SCREEN: ",$SELECT($PIECE(RA3,U,32)="y":"Patient answered yes",$PIECE(RA3,U,32)="n":"Patient answered no",$PIECE(RA3,U,32)="u":"Patient is unable to answer or is unsure",1:"")
+48 IF $PIECE(RA3,U,32)'="n"&$LENGTH(RAPCOMM)
WRITE !," PREGNANCY SCREEN COMMENT: ",RAPCOMM
+49 NEW RAPTAGE
SET RAPTAGE=$$PTAGE^RAUTL8(RADFN,"")
+50 IF RAPTAGE<12!(RAPTAGE>55)
QUIT
+51 IF $PIECE(RA3,U,32)'=""
Begin DoDot:2
+52 NEW RAFDA
+53 SET RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",32)=$PIECE(RA3,U,32)
+54 DO FILE^DIE("","RAFDA")
End DoDot:2
+55 IF $DATA(^RADPT(RADFN,"DT",RADTIEN,"P",RACNIEN,"PCOMM"))
Begin DoDot:2
+56 NEW RAFDA
+57 SET RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",80)=^RADPT(RADFN,"DT",RADTIEN,"P",RACNIEN,"PCOMM")
+58 DO FILE^DIE("","RAFDA")
End DoDot:2
End DoDot:1
+59 ;end of p99
+60 SET RAPARENT=$SELECT($GET(RAPARENT):RAPARENT,$PIECE($GET(^RAMIS(71,RAPROC,0)),U,6)="P":1,1:+$GET(RAPARENT))
+61 IF $DATA(^RAO(75.1,+RAOIFN,"H"))
IF $DATA(^("H",0))
SET ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0)=^(0)
FOR I=1:1
IF '$DATA(^RAO(75.1,+RAOIFN,"H",I,0))
QUIT
SET ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",I,0)=^(0)
+62 ;IHS/BJI/DAY - Patch 1003 - Continue Chris Saddler 2005 Patch
+63 ;Add set of Exam Date for PCC
+64 SET ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCC")=$PIECE(RADTE,".")
+65 ;End Patch
+66 SET ^DISV($SELECT($DATA(DUZ)#2:DUZ,1:0),"RA","CASE #")=RADFN_"^"_RADTI_"^"_RACNI
SET RAREC=""
+67 IF $DATA(RADPARFL)
SET ^TMP($JOB,"PRO-REG",RAPROCI,RAOIFN)=""
+68 KILL RAFIN,DR,RA703DAT
+69 KILL RACLNC,RALIFN,RALOC,RAOSTS,RAPHY,RAPRC,RARDTE,RARSH,RASHA
+70 QUIT
EXAMDEL ; Delete examset if incomplete
+1 WRITE !!?3,$CHAR(7),"Exam entry not complete. Must delete all descendent exams..."
+2 SET RATMP=0
+3 FOR
SET RATMP=$ORDER(^TMP($JOB,"RAREG1",RATMP))
IF RATMP'>0
QUIT
Begin DoDot:1
+4 SET RA=^TMP($JOB,"RAREG1",RATMP)
+5 SET RAOIFN=$PIECE(RA,U,4)
SET (RADFN,DA(2))=$PIECE(RA,U)
+6 SET (RADTI,DA(1))=$PIECE(RA,U,2)
SET (RACNI,DA)=$PIECE(RA,U,3)
+7 ; Modified the next line for rem call 249750
+8 SET DIK="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
DO ^DIK
+9 KILL ^TMP($JOB,"RAREG1",RATMP),RAPX(RATMP)
+10 KILL DIE,DR
SET DIE="^RAO(75.1,"
SET DA=RAOIFN
SET DR="5///5"
DO ^DIE
KILL DIE,DR
+11 QUIT
End DoDot:1
+12 WRITE !?3,"Deletion complete!",!
+13 QUIT
XTRADESC ; Ask extra descendent procedures for a parent
+1 NEW RASKIPIT
SET RASKIPIT=0
+2 FOR
Begin DoDot:1
+3 NEW DIR
SET DIR(0)="Y"
+4 SET DIR("A")="Register another descendent exam for "_RANME_" (Y/N)"
+5 WRITE !
DO ^DIR
+6 SET RAEXIT=$SELECT($DATA(DTOUT)!$DATA(DUOUT):1,1:0)
SET RASKIPIT='Y
+7 IF RASKIPIT!RAEXIT
QUIT
+8 DO ORDER
KILL RAPRC
IF RAQUIT
QUIT
+9 DO EXAMLOOP
DO MEMSET(RADFN,RADTI,RACNI)
+10 QUIT
End DoDot:1
IF RASKIPIT!RAEXIT!RAQUIT
QUIT
+11 QUIT
EXAMSET ; Set the EXAM SET field if a parent is registered
+1 NEW DA,DIE,DR,Y
+2 SET DIE="^RADPT("_RADFN_",""DT"","
+3 SET DA(1)=RADFN
SET DA=RADTI
+4 SET DR="5///^S X=$S($G(RAPARENT):''RAPARENT,1:""@"")"
+5 DO ^DIE
+6 QUIT
MEMSET(RAX,RAY,RAZ) ; Set 'MEMBER OF SET' field on the exam node
+1 ; if the procedure is a descendant procedure.
+2 ; Var List: RAX <-> RADFN : RAY <-> RADTI : RAZ <-> RACNI
+3 IF $GET(^RADPT(RAX,"DT",RAY,"P",RAZ,0))']""
QUIT
+4 NEW D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
+5 SET DIE="^RADPT("_RAX_",""DT"","_RAY_",""P"","
+6 ;2=combined report, 1=separate reports
SET DA(2)=RAX
SET DA(1)=RAY
SET DA=RAZ
SET DR="25///"_$SELECT($PIECE($GET(^RAMIS(71,+RAPROC,0)),"^",18)="Y":2,1:1)
DO ^DIE
+7 QUIT
SET17(RAX,RAY,RAZ) ; Set piece 17 on exam node
+1 IF $GET(^RADPT(RAX,"DT",RAY,"P",RAZ,0))']""
QUIT
+2 NEW D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
+3 SET DIE="^RADPT("_RAX_",""DT"","_RAY_",""P"","
+4 SET DA(2)=RAX
SET DA(1)=RAY
SET DA=RAZ
SET DR="17///"_RA17
DO ^DIE
+5 QUIT
UOSM ; called from RAREG1
+1 ; update order status and send OE v3.0 message
+2 ; This code will $O through the ^TMP($J,"RAREG1" global and make
+3 ; just one call per order/request number to ^RAORDU to update the
+4 ; status in File 75.1. One call to ^RAORDU per order/request number
+5 ; means only one HL7 type message per order/request will be sent to
+6 ; OE v3.0.
+7 ;
+8 IF '$DATA(^TMP($JOB,"RAREG1"))
QUIT
+9 NEW RACNT,RAORDNUM,RATMPNDE
+10 SET RACNT=0
+11 FOR
SET RACNT=$ORDER(^TMP($JOB,"RAREG1",RACNT))
IF RACNT'>0
QUIT
Begin DoDot:1
+12 SET RATMPNDE=$GET(^TMP($JOB,"RAREG1",RACNT))
+13 SET RAOIFN=$PIECE(RATMPNDE,U,4)
IF RAOIFN
Begin DoDot:2
+14 IF $DATA(RAORDNUM(RAOIFN))
QUIT
+15 SET RAPROC=$PIECE(^RAO(75.1,+RAOIFN,0),U,2)
+16 ;P18 - if the proc changed, sends XX mess, sets RA18PCHG=1 for RAORDU
NEW RA18PCHG
SET RA18PCHG=$$EN1^RAO7XX(RAOIFN)
+17 SET RAOSTS=6
DO ^RAORDU
+18 SET RAORDNUM(RAOIFN)=""
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 QUIT
CKDUPORD ; ck for dupl procedures in outstanding orders
+1 SET RA6=""
SET RA8=0
CKD1 SET RA6=$ORDER(^TMP($JOB,"PRO-REG",RA6))
IF 'RA6
QUIT
+1 SET RA7=$ORDER(^TMP($JOB,"PRO-REG",RA6,0))
IF 'RA7
GOTO CKD1
+2 ; kill hook for order of regist'd proc
KILL ^TMP($JOB,"PRO-ORD",RA6,RA7)
+3 IF '$ORDER(^TMP($JOB,"PRO-ORD",RA6,0))
GOTO CKD1
+4 IF 'RA8
WRITE !!?5,"Of the procedures you just registered,",!?5,"the following procedure(s) are still in outstanding order(s) :",$CHAR(7),!
+5 SET RA8=1
+6 SET RA7=""
+7 FOR
SET RA7=$ORDER(^TMP($JOB,"PRO-ORD",RA6,RA7))
IF 'RA7
QUIT
WRITE !?5,$PIECE(^RAMIS(71,RA6,0),U)
IF ^TMP($JOB,"PRO-ORD",RA6,RA7)="DESC"
WRITE ?35,"(parent=",$PIECE(^RAMIS(71,$PIECE($GET(^RAO(75.1,RA7,0)),U,2),0),U),")"
+8 GOTO CKD1
COPYFROM(RAZ) ;called by RAREG1 if add exam shd copy dx/staff/resident
+1 ;RAZ is "P"-node's ien of newly added case of set
+2 ;RAFIRST is "P"-node's ien of first case of set
IF '$DATA(RAFIRST)#2
QUIT
+3 IF $GET(^RADPT(RADFN,"DT",RADTI,"P",RAZ,0))']""
QUIT
+4 IF $GET(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,0))']""
QUIT
+5 NEW RA,RA2,RA3,RA5
SET RA5=0
+6 ; RA is a dummy var
+7 ; RA2 is used by data server call in RARTE2
+8 ; RA3 is used by COPYn^RARTE2 as a dummy var
+9 ; RA5=1 if any data got copied over to the new case
+10 ; prim res/staff
NEW RA1PR,RA1PS
+11 ; sec res/staff arrays
NEW RA1SR,RA1SS
+12 ; prim diag, then sec diags arrays
NEW RA1PD,RA1SD
+13 NEW RAFDA,RAIEN,RAMSG,RAXIT
+14 SET RAXIT=0
+15 SET RA2=RAZ_","_RADTI_","_RADFN
+16 ; get data from first case of set
+17 SET RA1PR=$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,0),U,12)
SET RA1PS=$PIECE(^(0),U,15)
SET RA1PD=$PIECE(^(0),U,13)
+18 IF $DATA(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"SRR",0))
SET RA=0
FOR
SET RA=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"SRR",RA))
IF +RA'=RA
QUIT
SET RA1SR(RA)=+(^(RA,0))
+19 IF $DATA(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"SSR",0))
SET RA=0
FOR
SET RA=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"SSR",RA))
IF +RA'=RA
QUIT
SET RA1SS(RA)=+(^(RA,0))
+20 IF $DATA(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"DX",0))
SET RA=0
FOR
SET RA=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RAFIRST,"DX",RA))
IF +RA'=RA
QUIT
SET RA1SD(RA)=+(^(RA,0))
+21 ; copy data from first case of set to new case
+22 IF RA1PR
SET $PIECE(^RADPT(RADFN,"DT",RADTI,"P",RAZ,0),U,12)=RA1PR
SET RA5=1
+23 IF RA1PS
SET $PIECE(^RADPT(RADFN,"DT",RADTI,"P",RAZ,0),U,15)=RA1PS
SET RA5=1
+24 IF RA1PD
SET $PIECE(^RADPT(RADFN,"DT",RADTI,"P",RAZ,0),U,13)=RA1PD
SET RA5=1
+25 IF $ORDER(RA1SR(""))
SET RA3=""
DO COPY3^RARTE2
SET RA5=1
+26 IF $ORDER(RA1SS(""))
SET RA3=""
DO COPY4^RARTE2
SET RA5=1
+27 IF $ORDER(RA1SD(""))
SET RA3=""
DO COPY5^RARTE2
SET RA5=1
+28 IF 'RA5
QUIT
+29 ; set xref for this new case only
+30 SET DIK="^RADPT("_RADFN_",""DT"","_RADTI_",""P"","
+31 SET DA(2)=RADFN
SET DA(1)=RADTI
SET DA=RAZ
+32 DO IX1^DIK
+33 QUIT
