RAPXRM ;HOIFO/SWM,GJC - API for Clinical Reminders ;04 Mar 2019 12:02 PM
;;5.0;Radiology/Nuclear Medicine;**33,56,153,156**;Mar 16, 1998;Build 1
; IA #3731 documents entry point EN1
; IA #4113 grants use of rtn PXRMSXRM
; IA #4114 grants use of direct Set and Kill, use of ^PXRMINDX(70
;Supported IA #2056 GET1^DIQ
;Supported IA #2052 GET1^DID
;Supported IA #10141 BMES^XPDUTL, MES^XPDUTL
;Supported IA #10103 NOW^XLFDT
;Supported IA #2171 $$NNT^XUAF4
;
EN1(RADAS,RARM) ;retrieve data from Clin. Rem.'s new style index "ACR"
; Input:
; RADAS = last subscript of (required), for example:
; ^PXRMINDX(70,"IP",43,1,2,2920720.1049,"2;DT;7079279.895;P;3;0")
; ^PXRMINDX(70,"PI",9,3,45,2921204.155,"9;DT;7078795.8449;P;1;0")
; RARM = array name passed by reference (required)
; Output:
; RARM("aaa") = external value, eg.:
; RARM("EXAM D/T") = Exam Date and time in yyymmdd.hhmm format
; RARM("EXAM STATUS") = Exam Status name
; RARM("PROCEDURE") = Procedure name
; RARM("INTERPRETING PHYSICIAN") = Primary Staff; else Primary Resident
; If exam node doesn't exist, then RARM is undefined
; RARM("RPT STATUS") = Report status name
; RARM("DIV") = Rad/Nuc Med Division Name (file 4) ^ Station #
; RARM("I-LOC") = Imaging Location name
;
K RARM ; clear output var
; validate RADAS string
Q:$P(RADAS,";",2)'="DT" Q:$P(RADAS,";",4)'="P" Q:$P(RADAS,";",6)'="0"
N RA0,RADFN,RADTI,RACNI,X,I,J,RARPT,RAY2
S RADFN=$P(RADAS,";"),RADTI=$P(RADAS,";",3),RACNI=$P(RADAS,";",5)
S RAY2=$G(^RADPT(RADFN,"DT",RADTI,0)) Q:RAY2=""
;* begin P156 *
;RAD/NUC MED DIVISION (#79) pointer --> $P(RAY2,U,3) DINUM'ed RA5P153
S RARM("DIV")=$$NNT^XUAF4(+$P(RAY2,U,3)) ;division name (file 4)
;IMAGING LOCATION (#79.1) --> $P(RAY2,U,4)
S RARM("I-LOC")=$$GET1^DIQ(79.1,+$P(RAY2,U,4),.01) ;(if X = 0 or null func returns null)
;* end P156/gjc
S RA0=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
Q:RA0=""
S RARM("EXAM D/T")=9999999.9999-RADTI
S RARM("EXAM STATUS")=$P($G(^RA(72,+$P(RA0,U,3),0)),U)
S RARM("PROCEDURE")=$P($G(^RAMIS(71,+$P(RA0,U,2),0)),U)
S X=$S($P(RA0,U,15):+$P(RA0,U,15),$P(RA0,U,12):+$P(RA0,U,12),1:"")
S:X'="" X=$$GET1^DIQ(200,X,.01)
S RARM("INTERPRETING PHYSICIAN")=X
;
; RARM("PDX")=Primary DX text
; this node won't exist if there's no data for Prim DX
; RARM("SDX",n)=Secondary DX text at ^RADPT(-,"DT",-,"P",-,"DX",n,0)
; the n may have gaps if a Secondary DX was deleted
;
S RARPT=$P(RA0,U,17) S RARM("RPT STATUS")=$$UL^RAO7PC1A($$RSTAT^RAO7PC1A())
S:$P(RA0,U,13)'="" RARM("PDX")=$P($G(^RA(78.3,+$P(RA0,U,13),0)),U)
S I=0
F S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",I)) Q:'I I $D(^(I,0)) S J=+$G(^(0)) I J S RARM("SDX",I)=$P($G(^RA(78.3,J,0)),U)
Q
;===============================================================
; RAD section copied from former location RAD^PXRMSXRO
RAD ;Build the index for RAD/NUC MED PATIENT.
N D0,D1,D2,DA,DAS,DFN,END,ENTRIES,GLOBAL,IND,NE,NERROR,PROC
N START,TEMP,TENP,TEXT
;Don't leave any old stuff around.
K ^PXRMINDX(70)
S GLOBAL=$$GET1^DID(70,"","","GLOBAL NAME")
S ENTRIES=$P(^RADPT(0),U,4)
S TENP=ENTRIES/10
S TENP=+$P(TENP,".",1)
I TENP<1 S TENP=1
D BMES^XPDUTL("Building index for RAD DATA")
S TEXT="There are "_ENTRIES_" entries to process."
D MES^XPDUTL(TEXT)
S START=$H
S (D0,IND,NE,NERROR)=0
F S D0=+$O(^RADPT(D0)) Q:D0=0 D
. S IND=IND+1
. I IND#TENP=0 D
.. S TEXT="Processing entry "_IND
.. D MES^XPDUTL(TEXT)
. I IND#10000=0 W "."
. S DFN=$P($G(^RADPT(D0,0)),U,1)
. I DFN="" D Q
.. S ETEXT=D0_" no patient"
.. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q
. S D1=0
. F S D1=+$O(^RADPT(D0,"DT",D1)) Q:D1=0 D
.. S DATE=$P($G(^RADPT(D0,"DT",D1,0)),U,1)
.. S DA=D0_";DT;"_D1
.. I DATE="" D Q
... S ETEXT=DA_" no date"
... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q
.. S D2=0
.. F S D2=+$O(^RADPT(D0,"DT",D1,"P",D2)) Q:D2=0 D
... S TEMP=$G(^RADPT(D0,"DT",D1,"P",D2,0))
... S DAS=DA_";P;"_D2_";0"
... S PROC=$P(TEMP,U,2)
... I PROC="" D Q
.... S ETEXT=DAS_" no procedure"
.... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q
... S ^PXRMINDX(70,"IP",PROC,DFN,DATE,DAS)=""
... S ^PXRMINDX(70,"PI",DFN,PROC,DATE,DAS)=""
... S NE=NE+1
S END=$H
S TEXT=NE_" RAD/NUC MED PATIENT results indexed."
D MES^XPDUTL(TEXT)
D DETIME^PXRMSXRM(START,END)
;If there were errors send a message.
I NERROR>0 D ERRMSG^PXRMSXRM(NERROR,GLOBAL)
;Send a MailMan message with the results.
D COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR)
S ^PXRMINDX(70,"GLOBAL NAME")=$$GET1^DID(70,"","","GLOBAL NAME")
S ^PXRMINDX(70,"BUILT BY")=DUZ
S ^PXRMINDX(70,"DATE BUILT")=$$NOW^XLFDT
Q
;
;===============================================================
KRAD(X,DA) ;Delete index for RAD/NUC MED PATIENT file.
N DAS,DATE
S DATE=9999999.9999-DA(1)
S DAS=DA(2)_";DT;"_DA(1)_";P;"_DA_";0"
K ^PXRMINDX(70,"IP",X(1),DA(2),DATE,DAS)
K ^PXRMINDX(70,"PI",DA(2),X(1),DATE,DAS)
Q
;
;===============================================================
SRAD(X,DA) ;Set index for RAD/NUC MED PATIENT file.
;DA(2)=DFN, DA(1)=EXAM DATE (inverse date), DA=Examinations Entry
;X(1)=PROCEDURE
N DAS,DATE
S DATE=9999999.9999-DA(1)
S DAS=DA(2)_";DT;"_DA(1)_";P;"_DA_";0"
S ^PXRMINDX(70,"IP",X(1),DA(2),DATE,DAS)=""
S ^PXRMINDX(70,"PI",DA(2),X(1),DATE,DAS)=""
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAPXRM 5434 printed Dec 13, 2024@02:39:02 Page 2
RAPXRM ;HOIFO/SWM,GJC - API for Clinical Reminders ;04 Mar 2019 12:02 PM
+1 ;;5.0;Radiology/Nuclear Medicine;**33,56,153,156**;Mar 16, 1998;Build 1
+2 ; IA #3731 documents entry point EN1
+3 ; IA #4113 grants use of rtn PXRMSXRM
+4 ; IA #4114 grants use of direct Set and Kill, use of ^PXRMINDX(70
+5 ;Supported IA #2056 GET1^DIQ
+6 ;Supported IA #2052 GET1^DID
+7 ;Supported IA #10141 BMES^XPDUTL, MES^XPDUTL
+8 ;Supported IA #10103 NOW^XLFDT
+9 ;Supported IA #2171 $$NNT^XUAF4
+10 ;
EN1(RADAS,RARM) ;retrieve data from Clin. Rem.'s new style index "ACR"
+1 ; Input:
+2 ; RADAS = last subscript of (required), for example:
+3 ; ^PXRMINDX(70,"IP",43,1,2,2920720.1049,"2;DT;7079279.895;P;3;0")
+4 ; ^PXRMINDX(70,"PI",9,3,45,2921204.155,"9;DT;7078795.8449;P;1;0")
+5 ; RARM = array name passed by reference (required)
+6 ; Output:
+7 ; RARM("aaa") = external value, eg.:
+8 ; RARM("EXAM D/T") = Exam Date and time in yyymmdd.hhmm format
+9 ; RARM("EXAM STATUS") = Exam Status name
+10 ; RARM("PROCEDURE") = Procedure name
+11 ; RARM("INTERPRETING PHYSICIAN") = Primary Staff; else Primary Resident
+12 ; If exam node doesn't exist, then RARM is undefined
+13 ; RARM("RPT STATUS") = Report status name
+14 ; RARM("DIV") = Rad/Nuc Med Division Name (file 4) ^ Station #
+15 ; RARM("I-LOC") = Imaging Location name
+16 ;
+17 ; clear output var
KILL RARM
+18 ; validate RADAS string
+19 if $PIECE(RADAS,";",2)'="DT"
QUIT
if $PIECE(RADAS,";",4)'="P"
QUIT
if $PIECE(RADAS,";",6)'="0"
QUIT
+20 NEW RA0,RADFN,RADTI,RACNI,X,I,J,RARPT,RAY2
+21 SET RADFN=$PIECE(RADAS,";")
SET RADTI=$PIECE(RADAS,";",3)
SET RACNI=$PIECE(RADAS,";",5)
+22 SET RAY2=$GET(^RADPT(RADFN,"DT",RADTI,0))
if RAY2=""
QUIT
+23 ;* begin P156 *
+24 ;RAD/NUC MED DIVISION (#79) pointer --> $P(RAY2,U,3) DINUM'ed RA5P153
+25 ;division name (file 4)
SET RARM("DIV")=$$NNT^XUAF4(+$PIECE(RAY2,U,3))
+26 ;IMAGING LOCATION (#79.1) --> $P(RAY2,U,4)
+27 ;(if X = 0 or null func returns null)
SET RARM("I-LOC")=$$GET1^DIQ(79.1,+$PIECE(RAY2,U,4),.01)
+28 ;* end P156/gjc
+29 SET RA0=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+30 if RA0=""
QUIT
+31 SET RARM("EXAM D/T")=9999999.9999-RADTI
+32 SET RARM("EXAM STATUS")=$PIECE($GET(^RA(72,+$PIECE(RA0,U,3),0)),U)
+33 SET RARM("PROCEDURE")=$PIECE($GET(^RAMIS(71,+$PIECE(RA0,U,2),0)),U)
+34 SET X=$SELECT($PIECE(RA0,U,15):+$PIECE(RA0,U,15),$PIECE(RA0,U,12):+$PIECE(RA0,U,12),1:"")
+35 if X'=""
SET X=$$GET1^DIQ(200,X,.01)
+36 SET RARM("INTERPRETING PHYSICIAN")=X
+37 ;
+38 ; RARM("PDX")=Primary DX text
+39 ; this node won't exist if there's no data for Prim DX
+40 ; RARM("SDX",n)=Secondary DX text at ^RADPT(-,"DT",-,"P",-,"DX",n,0)
+41 ; the n may have gaps if a Secondary DX was deleted
+42 ;
+43 SET RARPT=$PIECE(RA0,U,17)
SET RARM("RPT STATUS")=$$UL^RAO7PC1A($$RSTAT^RAO7PC1A())
+44 if $PIECE(RA0,U,13)'=""
SET RARM("PDX")=$PIECE($GET(^RA(78.3,+$PIECE(RA0,U,13),0)),U)
+45 SET I=0
+46 FOR
SET I=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",I))
if 'I
QUIT
IF $DATA(^(I,0))
SET J=+$GET(^(0))
IF J
SET RARM("SDX",I)=$PIECE($GET(^RA(78.3,J,0)),U)
+47 QUIT
+48 ;===============================================================
+49 ; RAD section copied from former location RAD^PXRMSXRO
RAD ;Build the index for RAD/NUC MED PATIENT.
+1 NEW D0,D1,D2,DA,DAS,DFN,END,ENTRIES,GLOBAL,IND,NE,NERROR,PROC
+2 NEW START,TEMP,TENP,TEXT
+3 ;Don't leave any old stuff around.
+4 KILL ^PXRMINDX(70)
+5 SET GLOBAL=$$GET1^DID(70,"","","GLOBAL NAME")
+6 SET ENTRIES=$PIECE(^RADPT(0),U,4)
+7 SET TENP=ENTRIES/10
+8 SET TENP=+$PIECE(TENP,".",1)
+9 IF TENP<1
SET TENP=1
+10 DO BMES^XPDUTL("Building index for RAD DATA")
+11 SET TEXT="There are "_ENTRIES_" entries to process."
+12 DO MES^XPDUTL(TEXT)
+13 SET START=$HOROLOG
+14 SET (D0,IND,NE,NERROR)=0
+15 FOR
SET D0=+$ORDER(^RADPT(D0))
if D0=0
QUIT
Begin DoDot:1
+16 SET IND=IND+1
+17 IF IND#TENP=0
Begin DoDot:2
+18 SET TEXT="Processing entry "_IND
+19 DO MES^XPDUTL(TEXT)
End DoDot:2
+20 IF IND#10000=0
WRITE "."
+21 SET DFN=$PIECE($GET(^RADPT(D0,0)),U,1)
+22 IF DFN=""
Begin DoDot:2
+23 SET ETEXT=D0_" no patient"
+24 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
QUIT
End DoDot:2
QUIT
+25 SET D1=0
+26 FOR
SET D1=+$ORDER(^RADPT(D0,"DT",D1))
if D1=0
QUIT
Begin DoDot:2
+27 SET DATE=$PIECE($GET(^RADPT(D0,"DT",D1,0)),U,1)
+28 SET DA=D0_";DT;"_D1
+29 IF DATE=""
Begin DoDot:3
+30 SET ETEXT=DA_" no date"
+31 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
QUIT
End DoDot:3
QUIT
+32 SET D2=0
+33 FOR
SET D2=+$ORDER(^RADPT(D0,"DT",D1,"P",D2))
if D2=0
QUIT
Begin DoDot:3
+34 SET TEMP=$GET(^RADPT(D0,"DT",D1,"P",D2,0))
+35 SET DAS=DA_";P;"_D2_";0"
+36 SET PROC=$PIECE(TEMP,U,2)
+37 IF PROC=""
Begin DoDot:4
+38 SET ETEXT=DAS_" no procedure"
+39 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
QUIT
End DoDot:4
QUIT
+40 SET ^PXRMINDX(70,"IP",PROC,DFN,DATE,DAS)=""
+41 SET ^PXRMINDX(70,"PI",DFN,PROC,DATE,DAS)=""
+42 SET NE=NE+1
End DoDot:3
End DoDot:2
End DoDot:1
+43 SET END=$HOROLOG
+44 SET TEXT=NE_" RAD/NUC MED PATIENT results indexed."
+45 DO MES^XPDUTL(TEXT)
+46 DO DETIME^PXRMSXRM(START,END)
+47 ;If there were errors send a message.
+48 IF NERROR>0
DO ERRMSG^PXRMSXRM(NERROR,GLOBAL)
+49 ;Send a MailMan message with the results.
+50 DO COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR)
+51 SET ^PXRMINDX(70,"GLOBAL NAME")=$$GET1^DID(70,"","","GLOBAL NAME")
+52 SET ^PXRMINDX(70,"BUILT BY")=DUZ
+53 SET ^PXRMINDX(70,"DATE BUILT")=$$NOW^XLFDT
+54 QUIT
+55 ;
+56 ;===============================================================
KRAD(X,DA) ;Delete index for RAD/NUC MED PATIENT file.
+1 NEW DAS,DATE
+2 SET DATE=9999999.9999-DA(1)
+3 SET DAS=DA(2)_";DT;"_DA(1)_";P;"_DA_";0"
+4 KILL ^PXRMINDX(70,"IP",X(1),DA(2),DATE,DAS)
+5 KILL ^PXRMINDX(70,"PI",DA(2),X(1),DATE,DAS)
+6 QUIT
+7 ;
+8 ;===============================================================
SRAD(X,DA) ;Set index for RAD/NUC MED PATIENT file.
+1 ;DA(2)=DFN, DA(1)=EXAM DATE (inverse date), DA=Examinations Entry
+2 ;X(1)=PROCEDURE
+3 NEW DAS,DATE
+4 SET DATE=9999999.9999-DA(1)
+5 SET DAS=DA(2)_";DT;"_DA(1)_";P;"_DA_";0"
+6 SET ^PXRMINDX(70,"IP",X(1),DA(2),DATE,DAS)=""
+7 SET ^PXRMINDX(70,"PI",DA(2),X(1),DATE,DAS)=""
+8 QUIT
+9 ;
