- 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 Feb 19, 2025@00:05:18 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 ;