RAMAG03C ;HCIOFO/SG - ORDERS/EXAMS API (REGISTR. UTILS) ; 06 Oct 2013 11:03 AM
;;5.0;Radiology/Nuclear Medicine;**90,47,1005**;Mar 16, 1998;Build 13
;
Q
;
;+++++ CREATES AN EXAM IN THE RAD/NUC MED PATIENT (#70)
;
; Input variables:
; RADFN, RADTE, RADTI, RAEXMVAL, RAIMGTYI, RALOCK, RAMDIV,
; RAMISC, RAMLC, RAOIFN, RAPARENT, RAPRLST, RASACN31
;
; Output variables:
; ^TMP($J,"RAREG1",...), RALOCK
;
; Return values:
; <0 Error descriptor (see $$ERROR^RAERR)
; 0 Success
;
; NOTE: This is an internal entry point. Do not call it from
; routines other than the ^RAMAG03.
;
EXAM() ;
Q:$D(RAPRLST)<10 0
N IENS,RACN,RACASE,RACRM,RAFDA,RAIENS,RAIP,RAMOS,RAMSG,RAPROC,RARC,TMP
K ^TMP($J,"RAREG1") S RARC=0
S RAMOS=$S('$G(RAPARENT):"",$G(RAMISC("SINGLERPT")):2,1:1)
;
;=== Create the date/time record if necessary
S TMP=$$ROOT^DILFD(70.02,","_RADFN_",",1)
I '$D(@TMP@(RADTI)) D Q:RARC<0 RARC
. S IENS="+1,"_RADFN_","
. S RAFDA(70.02,IENS,.01)=RADTE ; EXAM DATE
. S RAFDA(70.02,IENS,2)=RAIMGTYI ; TYPE OF IMAGING
. S RAFDA(70.02,IENS,3)=RAMDIV ; HOSPITAL DIVISION
. S RAFDA(70.02,IENS,4)=+RAMLC ; IMAGING LOCATION
. S:$G(RAPARENT) RAFDA(70.02,IENS,5)=1 ; EXAM SET
. S RAIENS(1)=RADTI
. D UPDATE^DIE(,"RAFDA","RAIENS","RAMSG")
. S:$G(DIERR) RARC=$$DBS^RAERR("RAMSG",-9,70.02,IENS)
;
;=== Get the credit method from the imaging location
S RACRM=$$GET1^DIQ(79.1,+RAMLC_",",21,"I",,"RAMSG")
Q:$G(DIERR) $$DBS^RAERR("RAMSG",-9,79.1,+RAMLC_",")
;
;=== Register individual case(s)
S RAIP=0
F S RAIP=$O(RAPRLST(RAIP)) Q:RAIP'>0 D Q:RARC<0
. S RAPROC=RAPRLST(RAIP) K RAFDA,RAIENS,RAMSG
. ;--- Generate a case number
. S RACN=$$CASENUM^RAMAG03D(RADTE)
. I RACN<0 S RARC=RACN Q
. ;--- Prepare the data
. S IENS="+1,"_RADTI_","_RADFN_","
. S RAFDA(70.03,IENS,.01)=RACN ; CASE NUMBER
. S RAFDA(70.03,IENS,2)=+RAPROC ; PROCEDURE
. S RAFDA(70.03,IENS,4)=RAMISC("EXAMCAT") ; CATEGORY OF EXAM
. S RAFDA(70.03,IENS,6)=$G(RAMISC("WARD")) ; WARD
. S RAFDA(70.03,IENS,7)=$G(RAMISC("SERVICE")) ; SERVICE
. S RAFDA(70.03,IENS,8)=$G(RAMISC("PRINCLIN")) ; PRINCIPAL CLINIC
. S RAFDA(70.03,IENS,11)=RAOIFN ; IMAGING ORDER
. S RAFDA(70.03,IENS,19)=$G(RAMISC("BEDSECT")) ; BEDSECTION
. S RAFDA(70.03,IENS,25)=RAMOS ; MEMBER OF SET
. S RAFDA(70.03,IENS,26)=RACRM ; CREDIT METHOD
. ;---Pregnancy Screen and Pregnancy Screen Comment for female pt ages 12-55
. ;IHS/BJI/DAY - Patch 1005 - Gender Fix
. ;I $$PTSEX^RAUTL8(RADFN)="F",(($$PTAGE^RAUTL8(RADFN,"")>11)!($$PTAGE^RAUTL8(RADFN,"")<56)) D
. I $$PTSEX^RAUTL8(RADFN)'="M",$$PTAGE^RAUTL8(RADFN,"")>11,$$PTAGE^RAUTL8(RADFN,"")<56 D
.. ;
.. S RAFDA(70.03,IENS,32)="u"
.. S RAFDA(70.03,IENS,80)="OUTSIDE STUDY"
. ;--- SITE ACCESSION NUMBER
. S:$G(RASACN31) RAFDA(70.03,IENS,31)=$$ACCNUM^RAMAGU04(RADTE,RACN)
. ;--- CLINICAL HISTORY FOR EXAM
. S TMP=$NA(RAMISC("CLINHIST"))
. S:$D(@TMP)>1 RAFDA(70.03,IENS,400)=TMP
. ;--- Values from the order
. M RAFDA(70.03,IENS)=RAEXMVAL
. ;--- Add the record
. D UPDATE^DIE(,"RAFDA","RAIENS","RAMSG")
. I $G(DIERR) S RARC=$$DBS^RAERR("RAMSG",-9,70.03,IENS) Q
. S RACASE=RADFN_U_RADTI_U_RAIENS(1)
. ;--- Add to the list
. S ^TMP($J,"RAREG1",RAIP)=RACASE_U_RAOIFN
. ;--- Procedure modifiers
. S $P(IENS,",")=RAIENS(1)
. S RARC=$$PROCMOD(IENS,RAPROC) Q:RARC<0
. ;---Study Instance UID (70.03; 81)
. D SIUID($P(IENS,",")) ;where IENS is RACNI,RADTI,RADFN,
. I $G(DIERR) S RARC=$$DBS^RAERR("RAMSG",-9,70.03,IENS) Q
. ;--- Exam status
. S RARC=$$UPDEXMST^RAMAGU05(RACASE,"^^1") Q:RARC<0
. ;--- Activity log
. S TMP=$G(RAMISC("TECHCOMM"))
. S RARC=$$UPDEXMAL^RAMAGU05(RACASE,"E",TMP) Q:RARC<0
;
;===
Q $S(RARC<0:RARC,1:0)
;
;+++++ PERFORMS EXAM POST-PROCESSING
;
; .RAEXAMS Reference to a local array where identifiers of
; registered examination(s) are returned to.
;
; RADTE Actual date/time of the exam (FileMan)
;
; Input variables:
; RASACN31, ^TMP($J,"RAREG1",...)
;
; Return values:
; <0 Error descriptor (see $$ERROR^RAERR)
; '<0 Number of registered examinations
; (number of elements in the RAEXAMS array)
;
POSTPROC(RAEXAMS,RADTE) ;
N IENS,RABUF,RACASE,RACN,RACNI,RADFN,RADTI,RAEXMCNT,RAI,RAMSG,RAOIFN
S RAEXMCNT=0 K RAEXAMS
;===
S RAI=0
F S RAI=$O(^TMP($J,"RAREG1",RAI)) Q:RAI'>0 D
. S RACASE=^TMP($J,"RAREG1",RAI) K RABUF,RAMSG
. S RADFN=$P(RACASE,U),RADTI=$P(RACASE,U,2)
. S RACNI=$P(RACASE,U,3),RAOIFN=$P(RACASE,U,4)
. S IENS=$$EXAMIENS^RAMAGU04(RACASE)
. ;--- Exam identifiers
. S RACN=$$GET1^DIQ(70.03,IENS,.01,"I",,"RAMSG")
. S $P(RACASE,U,4)=RACN ; Case number
. I $G(RASACN31) D ; Accession number
. . S $P(RACASE,U,5)=$$GET1^DIQ(70.03,IENS,31,"I",,"RAMSG")
. E S $P(RACASE,U,5)=$$ACCNUM^RAMAGU04(RADTE,RACN,"S")
. S $P(RACASE,U,6)=RADTE ; Exam date/time
. S RAEXMCNT=RAEXMCNT+1,RAEXAMS(RAEXMCNT)=RACASE
. ;--- Execute RA REG* protocols
. D REG^RAHLRPC
. ;--- Remove from the list
. K ^TMP($J,"RAREG1",RAI)
;===
Q RAEXMCNT
;
;+++++ STORES PROCEDURE MODIFIERS
;
; IENS7003 IENS of the exam in the sub-file #70.03
;
; RAPROC Radiology procedure and modifiers
; ^01: Procedure IEN in file #71
; ^02: Optional procedure modifiers (IENs in
; ... the PROCEDURE MODIFIERS file (#71.2))
; ^nn:
;
; Return values:
; <0 Error descriptor (see $$ERROR^RAERR)
; 0 Success
;
; NOTE: This is an internal entry point. Do not call it from
; outside of this routine.
;
PROCMOD(IENS7003,RAPROC) ;
N I,IENS,LP,RAFDA,RAMSG,RAPMCNT,RARC,TMP
S (RAPMCNT,RARC)=0
;--- Prepare the data
S LP=$L(RAPROC,U)
F I=2:1:LP S TMP=$P(RAPROC,U,I) D:TMP'=""
. S RAPMCNT=RAPMCNT+1,IENS="+"_RAPMCNT_","_IENS7003
. S RAFDA(70.1,IENS,.01)="`"_TMP
;--- Store procedure modifiers
D:RAPMCNT>0
. D UPDATE^DIE("E","RAFDA",,"RAMSG")
. S:$G(DIERR) RARC=$$DBS^RAERR("RAMSG",-9,70.1)
;---
Q RARC
;
SIUID(RACNI) ;
;sets field 81 IN 70.03
;IENS, RADFN & RADTI are global
N RAFDA S RAFDA(70.03,IENS,81)=$$SIUID^RAAPI
D FILE^DIE("","RAFDA")
Q
RAMAG03C ;HCIOFO/SG - ORDERS/EXAMS API (REGISTR. UTILS) ; 06 Oct 2013 11:03 AM
+1 ;;5.0;Radiology/Nuclear Medicine;**90,47,1005**;Mar 16, 1998;Build 13
+2 ;
+3 QUIT
+4 ;
+5 ;+++++ CREATES AN EXAM IN THE RAD/NUC MED PATIENT (#70)
+6 ;
+7 ; Input variables:
+8 ; RADFN, RADTE, RADTI, RAEXMVAL, RAIMGTYI, RALOCK, RAMDIV,
+9 ; RAMISC, RAMLC, RAOIFN, RAPARENT, RAPRLST, RASACN31
+10 ;
+11 ; Output variables:
+12 ; ^TMP($J,"RAREG1",...), RALOCK
+13 ;
+14 ; Return values:
+15 ; <0 Error descriptor (see $$ERROR^RAERR)
+16 ; 0 Success
+17 ;
+18 ; NOTE: This is an internal entry point. Do not call it from
+19 ; routines other than the ^RAMAG03.
+20 ;
EXAM() ;
+1 IF $DATA(RAPRLST)<10
QUIT 0
+2 NEW IENS,RACN,RACASE,RACRM,RAFDA,RAIENS,RAIP,RAMOS,RAMSG,RAPROC,RARC,TMP
+3 KILL ^TMP($JOB,"RAREG1")
SET RARC=0
+4 SET RAMOS=$SELECT('$GET(RAPARENT):"",$GET(RAMISC("SINGLERPT")):2,1:1)
+5 ;
+6 ;=== Create the date/time record if necessary
+7 SET TMP=$$ROOT^DILFD(70.02,","_RADFN_",",1)
+8 IF '$DATA(@TMP@(RADTI))
Begin DoDot:1
+9 SET IENS="+1,"_RADFN_","
+10 ; EXAM DATE
SET RAFDA(70.02,IENS,.01)=RADTE
+11 ; TYPE OF IMAGING
SET RAFDA(70.02,IENS,2)=RAIMGTYI
+12 ; HOSPITAL DIVISION
SET RAFDA(70.02,IENS,3)=RAMDIV
+13 ; IMAGING LOCATION
SET RAFDA(70.02,IENS,4)=+RAMLC
+14 ; EXAM SET
IF $GET(RAPARENT)
SET RAFDA(70.02,IENS,5)=1
+15 SET RAIENS(1)=RADTI
+16 DO UPDATE^DIE(,"RAFDA","RAIENS","RAMSG")
+17 IF $GET(DIERR)
SET RARC=$$DBS^RAERR("RAMSG",-9,70.02,IENS)
End DoDot:1
IF RARC<0
QUIT RARC
+18 ;
+19 ;=== Get the credit method from the imaging location
+20 SET RACRM=$$GET1^DIQ(79.1,+RAMLC_",",21,"I",,"RAMSG")
+21 IF $GET(DIERR)
QUIT $$DBS^RAERR("RAMSG",-9,79.1,+RAMLC_",")
+22 ;
+23 ;=== Register individual case(s)
+24 SET RAIP=0
+25 FOR
SET RAIP=$ORDER(RAPRLST(RAIP))
IF RAIP'>0
QUIT
Begin DoDot:1
+26 SET RAPROC=RAPRLST(RAIP)
KILL RAFDA,RAIENS,RAMSG
+27 ;--- Generate a case number
+28 SET RACN=$$CASENUM^RAMAG03D(RADTE)
+29 IF RACN<0
SET RARC=RACN
QUIT
+30 ;--- Prepare the data
+31 SET IENS="+1,"_RADTI_","_RADFN_","
+32 ; CASE NUMBER
SET RAFDA(70.03,IENS,.01)=RACN
+33 ; PROCEDURE
SET RAFDA(70.03,IENS,2)=+RAPROC
+34 ; CATEGORY OF EXAM
SET RAFDA(70.03,IENS,4)=RAMISC("EXAMCAT")
+35 ; WARD
SET RAFDA(70.03,IENS,6)=$GET(RAMISC("WARD"))
+36 ; SERVICE
SET RAFDA(70.03,IENS,7)=$GET(RAMISC("SERVICE"))
+37 ; PRINCIPAL CLINIC
SET RAFDA(70.03,IENS,8)=$GET(RAMISC("PRINCLIN"))
+38 ; IMAGING ORDER
SET RAFDA(70.03,IENS,11)=RAOIFN
+39 ; BEDSECTION
SET RAFDA(70.03,IENS,19)=$GET(RAMISC("BEDSECT"))
+40 ; MEMBER OF SET
SET RAFDA(70.03,IENS,25)=RAMOS
+41 ; CREDIT METHOD
SET RAFDA(70.03,IENS,26)=RACRM
+42 ;---Pregnancy Screen and Pregnancy Screen Comment for female pt ages 12-55
+43 ;IHS/BJI/DAY - Patch 1005 - Gender Fix
+44 ;I $$PTSEX^RAUTL8(RADFN)="F",(($$PTAGE^RAUTL8(RADFN,"")>11)!($$PTAGE^RAUTL8(RADFN,"")<56)) D
+45 IF $$PTSEX^RAUTL8(RADFN)'="M"
IF $$PTAGE^RAUTL8(RADFN,"")>11
IF $$PTAGE^RAUTL8(RADFN,"")<56
Begin DoDot:2
+46 ;
+47 SET RAFDA(70.03,IENS,32)="u"
+48 SET RAFDA(70.03,IENS,80)="OUTSIDE STUDY"
End DoDot:2
+49 ;--- SITE ACCESSION NUMBER
+50 IF $GET(RASACN31)
SET RAFDA(70.03,IENS,31)=$$ACCNUM^RAMAGU04(RADTE,RACN)
+51 ;--- CLINICAL HISTORY FOR EXAM
+52 SET TMP=$NAME(RAMISC("CLINHIST"))
+53 IF $DATA(@TMP)>1
SET RAFDA(70.03,IENS,400)=TMP
+54 ;--- Values from the order
+55 MERGE RAFDA(70.03,IENS)=RAEXMVAL
+56 ;--- Add the record
+57 DO UPDATE^DIE(,"RAFDA","RAIENS","RAMSG")
+58 IF $GET(DIERR)
SET RARC=$$DBS^RAERR("RAMSG",-9,70.03,IENS)
QUIT
+59 SET RACASE=RADFN_U_RADTI_U_RAIENS(1)
+60 ;--- Add to the list
+61 SET ^TMP($JOB,"RAREG1",RAIP)=RACASE_U_RAOIFN
+62 ;--- Procedure modifiers
+63 SET $PIECE(IENS,",")=RAIENS(1)
+64 SET RARC=$$PROCMOD(IENS,RAPROC)
IF RARC<0
QUIT
+65 ;---Study Instance UID (70.03; 81)
+66 ;where IENS is RACNI,RADTI,RADFN,
DO SIUID($PIECE(IENS,","))
+67 IF $GET(DIERR)
SET RARC=$$DBS^RAERR("RAMSG",-9,70.03,IENS)
QUIT
+68 ;--- Exam status
+69 SET RARC=$$UPDEXMST^RAMAGU05(RACASE,"^^1")
IF RARC<0
QUIT
+70 ;--- Activity log
+71 SET TMP=$GET(RAMISC("TECHCOMM"))
+72 SET RARC=$$UPDEXMAL^RAMAGU05(RACASE,"E",TMP)
IF RARC<0
QUIT
End DoDot:1
IF RARC<0
QUIT
+73 ;
+74 ;===
+75 QUIT $SELECT(RARC<0:RARC,1:0)
+76 ;
+77 ;+++++ PERFORMS EXAM POST-PROCESSING
+78 ;
+79 ; .RAEXAMS Reference to a local array where identifiers of
+80 ; registered examination(s) are returned to.
+81 ;
+82 ; RADTE Actual date/time of the exam (FileMan)
+83 ;
+84 ; Input variables:
+85 ; RASACN31, ^TMP($J,"RAREG1",...)
+86 ;
+87 ; Return values:
+88 ; <0 Error descriptor (see $$ERROR^RAERR)
+89 ; '<0 Number of registered examinations
+90 ; (number of elements in the RAEXAMS array)
+91 ;
POSTPROC(RAEXAMS,RADTE) ;
+1 NEW IENS,RABUF,RACASE,RACN,RACNI,RADFN,RADTI,RAEXMCNT,RAI,RAMSG,RAOIFN
+2 SET RAEXMCNT=0
KILL RAEXAMS
+3 ;===
+4 SET RAI=0
+5 FOR
SET RAI=$ORDER(^TMP($JOB,"RAREG1",RAI))
IF RAI'>0
QUIT
Begin DoDot:1
+6 SET RACASE=^TMP($JOB,"RAREG1",RAI)
KILL RABUF,RAMSG
+7 SET RADFN=$PIECE(RACASE,U)
SET RADTI=$PIECE(RACASE,U,2)
+8 SET RACNI=$PIECE(RACASE,U,3)
SET RAOIFN=$PIECE(RACASE,U,4)
+9 SET IENS=$$EXAMIENS^RAMAGU04(RACASE)
+10 ;--- Exam identifiers
+11 SET RACN=$$GET1^DIQ(70.03,IENS,.01,"I",,"RAMSG")
+12 ; Case number
SET $PIECE(RACASE,U,4)=RACN
+13 ; Accession number
IF $GET(RASACN31)
Begin DoDot:2
+14 SET $PIECE(RACASE,U,5)=$$GET1^DIQ(70.03,IENS,31,"I",,"RAMSG")
End DoDot:2
+15 IF '$TEST
SET $PIECE(RACASE,U,5)=$$ACCNUM^RAMAGU04(RADTE,RACN,"S")
+16 ; Exam date/time
SET $PIECE(RACASE,U,6)=RADTE
+17 SET RAEXMCNT=RAEXMCNT+1
SET RAEXAMS(RAEXMCNT)=RACASE
+18 ;--- Execute RA REG* protocols
+19 DO REG^RAHLRPC
+20 ;--- Remove from the list
+21 KILL ^TMP($JOB,"RAREG1",RAI)
End DoDot:1
+22 ;===
+23 QUIT RAEXMCNT
+24 ;
+25 ;+++++ STORES PROCEDURE MODIFIERS
+26 ;
+27 ; IENS7003 IENS of the exam in the sub-file #70.03
+28 ;
+29 ; RAPROC Radiology procedure and modifiers
+30 ; ^01: Procedure IEN in file #71
+31 ; ^02: Optional procedure modifiers (IENs in
+32 ; ... the PROCEDURE MODIFIERS file (#71.2))
+33 ; ^nn:
+34 ;
+35 ; Return values:
+36 ; <0 Error descriptor (see $$ERROR^RAERR)
+37 ; 0 Success
+38 ;
+39 ; NOTE: This is an internal entry point. Do not call it from
+40 ; outside of this routine.
+41 ;
PROCMOD(IENS7003,RAPROC) ;
+1 NEW I,IENS,LP,RAFDA,RAMSG,RAPMCNT,RARC,TMP
+2 SET (RAPMCNT,RARC)=0
+3 ;--- Prepare the data
+4 SET LP=$LENGTH(RAPROC,U)
+5 FOR I=2:1:LP
SET TMP=$PIECE(RAPROC,U,I)
IF TMP'=""
Begin DoDot:1
+6 SET RAPMCNT=RAPMCNT+1
SET IENS="+"_RAPMCNT_","_IENS7003
+7 SET RAFDA(70.1,IENS,.01)="`"_TMP
End DoDot:1
+8 ;--- Store procedure modifiers
+9 IF RAPMCNT>0
Begin DoDot:1
+10 DO UPDATE^DIE("E","RAFDA",,"RAMSG")
+11 IF $GET(DIERR)
SET RARC=$$DBS^RAERR("RAMSG",-9,70.1)
End DoDot:1
+12 ;---
+13 QUIT RARC
+14 ;
SIUID(RACNI) ;
+1 ;sets field 81 IN 70.03
+2 ;IENS, RADFN & RADTI are global
+3 NEW RAFDA
SET RAFDA(70.03,IENS,81)=$$SIUID^RAAPI
+4 DO FILE^DIE("","RAFDA")
+5 QUIT
