RORRP021 ;HCIOFO/SG - RPC: PATIENT DATA ; 8/19/05 10:28am
;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
;
Q
;
;***** LOADS THE PATIENT DATA
; RPC: [ROR PATIENT GET DATA]
;
; .RESULTS Reference to a local variable where the results
; are returned to.
;
; PTIEN IEN of the patient (DFN)
;
; [FLAGS] Flags that control the execution (can be combined):
; A Load the patient's address
; E Load the ethnicity information
; L Load values of patient's active local fields
; R Load the race information
; S Load the selection rules
;
; The "L" and "S" flags require the REGIEN parameter.
; Otherwise, they are ignored.
;
; [REGIEN] Registry IEN.
; If value of this parameter is greater than 0
; then the "PRD" segment with the basic patient's
; registry data will be returned. If the patient
; is not in the registry then an empty "PRD" segment
; will be returned anyway.
;
; Return Values:
;
; A negative value of the first "^"-piece of the RESULTS(0)
; indicates an error (see the RPCSTK^RORERR procedure for more
; details).
;
; Otherwise, zero is returned in the RESULTS(0) and the subsequent
; nodes of the array contain the patient's data.
;
; RESULTS(0) 0
;
; RESULTS(i) Demographic Information
; ^01: "DEM"
; ^02: ""
; ... See the $$LOAD2^RORRP020 (RORDEM)
;
; RESULTS(i) Patient's Address
; ^01: "ADR"
; ^02: ""
; ... See the $$LOAD2^RORRP020 (RORADR)
;
; RESULTS(i) Race Information
; ^01: "RCE"
; ^02: Race IEN
; ^03: Race HL7 Value
; ^04: Race
; ^05: Collection Method HL7 Value
; ^06: Collection Method
;
; Race HL7 Values
; 1002-5 American Indian or Alaska Native
; 2028-9 Asian
; 2054-5 Black or African American
; 0000-0 Declined to Answer
; 2076-8 Native Hawaiian or Pacific Islander
; 9999-4 Unknown by Patient
; 2106-3 White
;
; Collection Method HL7 Values
; OBS Observer
; PRX Proxy
; SLF Self Identification
; UNK Unknown
;
; RESULTS(i) Ethnicity Information
; ^01: "ETN"
; ^02: Ethnicity IEN
; ^03: Ethnicity HL7 Value
; ^04: Ethnicity
; ^05: Collection Method HL7 value
; ^06: Collection Method
;
; Ethnicity HL7 Values
; 0000-0 Declined to Answer
; 2135-2 Hispanic or Latino
; 2186-5 Not Hispanic or Latino
; 9999-4 Unknown by Patient
;
; RESULTS(i) Patient's Registry Data
; ^01: "PRD"
; ^02: ""
; ... See the $$LOAD798^RORRP020
;
; RESULTS(i) Local field data
; ^O1: "LFV"
; ^02: IEN in the LOCAL FIELD multiple
; of the ROR REGISTRY RECORD file
; ^03: Field Definition IEN
; (in the ROR LOCAL FIELD file)
; ^04: Field Name
; ^05: Date (FileMan)
; ^06: Comment
;
; RESULTS(i) Selection Rule
; ^01: "PSR"
; ^02: IEN in the SELECTION RULE multiple
; of the ROR REGISTRY RECORD file
; ^03: Rule Definition IEN
; (in the ROR SELECTION RULE file)
; ^04: Name of the Rule
; ^05: Date (FileMan)
; ^06: Location IEN (Institution IEN)
; ^07: Location Name (Institution Name)
; ^08: Short Description
;
GETPTDAT(RESULTS,PTIEN,FLAGS,REGIEN) ;
N BUF,BUF1,DOD,IEN,RC,RESPTR,RORERRDL,VADM
D CLEAR^RORERR("GETPTDAT^RORRP021",1)
K RESULTS S (RESULTS(0),RESPTR)=0
;=== Check the parameters
S RC=0 D I RC<0 D RPCSTK^RORERR(.RESULTS,RC) Q
. ;--- Patient IEN
. I $G(PTIEN)'>0 D Q
. . S RC=$$ERROR^RORERR(-88,,,,"PTIEN",$G(PTIEN))
. S PTIEN=+PTIEN
. ;--- Flags
. S FLAGS=$$UP^XLFSTR($G(FLAGS))
;=== Load the data from the PATIENT file
S RC=$$LOAD2^RORRP020(PTIEN,.BUF,.BUF1,.VADM)
I RC<0 D RPCSTK^RORERR(.RESULTS,RC) Q
S DOD=$P(BUF,U,5)
;
;=== Demographic information and address
S RESPTR=RESPTR+1,RESULTS(RESPTR)="DEM^^"_BUF
S:FLAGS["A" RESPTR=RESPTR+1,RESULTS(RESPTR)="ADR^^"_BUF1
;
;=== Race information
I FLAGS["R" D:$G(VADM(12))>0
. N I,METHOD,RACE
. S I=""
. F S I=$O(VADM(12,I)) Q:I="" D
. . S RACE=$G(VADM(12,I)) Q:RACE'>0
. . S METHOD=$G(VADM(12,I,1))
. . S BUF="RCE"_U_(+RACE)
. . ;---
. . S $P(BUF,U,3)=$$PTR2CODE^DGUTL4(+RACE,1,2)
. . S $P(BUF,U,4)=$P(RACE,U,2)
. . S $P(BUF,U,5)=$$PTR2CODE^DGUTL4(+METHOD,3,2)
. . S $P(BUF,U,6)=$P(METHOD,U,2)
. . ;---
. . S RESPTR=RESPTR+1,RESULTS(RESPTR)=BUF
;
;=== Ethnicity information
I FLAGS["E" D:$G(VADM(11))>0
. N ETHN,I,METHOD
. S I=""
. F S I=$O(VADM(11,I)) Q:I="" D
. . S ETHN=$G(VADM(11,I)) Q:ETHN'>0
. . S METHOD=$G(VADM(11,I,1))
. . S BUF="ETN"_U_(+ETHN)
. . ;---
. . S $P(BUF,U,3)=$$PTR2CODE^DGUTL4(+ETHN,2,2)
. . S $P(BUF,U,4)=$P(ETHN,U,2)
. . S $P(BUF,U,5)=$$PTR2CODE^DGUTL4(+METHOD,3,2)
. . S $P(BUF,U,6)=$P(METHOD,U,2)
. . ;---
. . S RESPTR=RESPTR+1,RESULTS(RESPTR)=BUF
;
;=== Patient's registry data
I $G(REGIEN)>0 D I RC<0 D RPCSTK^RORERR(.RESULTS,RC) Q
. S RESPTR=RESPTR+1
. ;--- Get the IEN of the registry record
. S IEN=$$PRRIEN^RORUTL01(PTIEN,REGIEN)
. I IEN'>0 S RESULTS(RESPTR)="PRD" Q
. ;--- Load the data from the patient's registry record
. S RC=$$LOAD798^RORRP020(IEN,.BUF,DOD) Q:RC<0
. S RESULTS(RESPTR)="PRD^^"_BUF
. ;--- Local field values
. I FLAGS["L" D Q:RC<0
. . S RC=$$LFV(IEN,.RESULTS,.RESPTR)
. ;--- Selection rules
. I FLAGS["S" D Q:RC<0
. . S RC=$$PSR(IEN,.RESULTS,.RESPTR)
;===
Q
;
;***** GET THE LOCAL FIELD VALUES
LFV(IEN798,RESULTS,RESPTR) ;
N I,IEN,IENS,RORBUF,SCR,RORMSG
S DT=$$DT^XLFDT
;--- Load the data
S SCR="I $$LFACTIVE^RORDD01(+$G(^(0)))"
S IENS=","_IEN798_",",I="@;.01I;.01E;.02I;1"
D LIST^DIC(798.02,IENS,I,"P",,,,"B",SCR,,"RORBUF","RORMSG")
Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,,798.02,IENS)
;--- Add the data to the output array
S I=0
F S I=$O(RORBUF("DILIST",I)) Q:I'>0 D
. S RESPTR=RESPTR+1
. S RESULTS(RESPTR)="LFV^"_RORBUF("DILIST",I,0)
;--- Success
Q 0
;
;***** GET THE SELECTION RULES
PSR(IEN798,RESULTS,RESPTR) ;
N BUF,I,IEN,IENS,RORBUF,RORMSG,TMP
;--- Load the data
S IENS=","_IEN798_",",TMP="@;.01I;.01E;1I;2I;2E"
D LIST^DIC(798.01,IENS,TMP,"P",,,,"AD",,,"RORBUF","RORMSG")
Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,,798.01,IENS)
;--- Add the data to the output array
S I=0
F S I=$O(RORBUF("DILIST",I)) Q:I'>0 D
. S BUF=RORBUF("DILIST",I,0),IEN=+$P(BUF,U,2) Q:IEN'>0
. S TMP=$$GET1^DIQ(798.2,IEN_",",4,,,"RORMSG")
. D:$G(DIERR) DBS^RORERR("RORMSG",-9,,,798.2,IEN_",")
. S $P(BUF,U,7)=$S(TMP'="":TMP,1:$P(BUF,U,3))
. S RESPTR=RESPTR+1,RESULTS(RESPTR)="PSR^"_BUF
;--- Success
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORRP021 8186 printed Apr 09, 2024@20:50:05 Page 2
RORRP021 ;HCIOFO/SG - RPC: PATIENT DATA ; 8/19/05 10:28am
+1 ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
+2 ;
+3 QUIT
+4 ;
+5 ;***** LOADS THE PATIENT DATA
+6 ; RPC: [ROR PATIENT GET DATA]
+7 ;
+8 ; .RESULTS Reference to a local variable where the results
+9 ; are returned to.
+10 ;
+11 ; PTIEN IEN of the patient (DFN)
+12 ;
+13 ; [FLAGS] Flags that control the execution (can be combined):
+14 ; A Load the patient's address
+15 ; E Load the ethnicity information
+16 ; L Load values of patient's active local fields
+17 ; R Load the race information
+18 ; S Load the selection rules
+19 ;
+20 ; The "L" and "S" flags require the REGIEN parameter.
+21 ; Otherwise, they are ignored.
+22 ;
+23 ; [REGIEN] Registry IEN.
+24 ; If value of this parameter is greater than 0
+25 ; then the "PRD" segment with the basic patient's
+26 ; registry data will be returned. If the patient
+27 ; is not in the registry then an empty "PRD" segment
+28 ; will be returned anyway.
+29 ;
+30 ; Return Values:
+31 ;
+32 ; A negative value of the first "^"-piece of the RESULTS(0)
+33 ; indicates an error (see the RPCSTK^RORERR procedure for more
+34 ; details).
+35 ;
+36 ; Otherwise, zero is returned in the RESULTS(0) and the subsequent
+37 ; nodes of the array contain the patient's data.
+38 ;
+39 ; RESULTS(0) 0
+40 ;
+41 ; RESULTS(i) Demographic Information
+42 ; ^01: "DEM"
+43 ; ^02: ""
+44 ; ... See the $$LOAD2^RORRP020 (RORDEM)
+45 ;
+46 ; RESULTS(i) Patient's Address
+47 ; ^01: "ADR"
+48 ; ^02: ""
+49 ; ... See the $$LOAD2^RORRP020 (RORADR)
+50 ;
+51 ; RESULTS(i) Race Information
+52 ; ^01: "RCE"
+53 ; ^02: Race IEN
+54 ; ^03: Race HL7 Value
+55 ; ^04: Race
+56 ; ^05: Collection Method HL7 Value
+57 ; ^06: Collection Method
+58 ;
+59 ; Race HL7 Values
+60 ; 1002-5 American Indian or Alaska Native
+61 ; 2028-9 Asian
+62 ; 2054-5 Black or African American
+63 ; 0000-0 Declined to Answer
+64 ; 2076-8 Native Hawaiian or Pacific Islander
+65 ; 9999-4 Unknown by Patient
+66 ; 2106-3 White
+67 ;
+68 ; Collection Method HL7 Values
+69 ; OBS Observer
+70 ; PRX Proxy
+71 ; SLF Self Identification
+72 ; UNK Unknown
+73 ;
+74 ; RESULTS(i) Ethnicity Information
+75 ; ^01: "ETN"
+76 ; ^02: Ethnicity IEN
+77 ; ^03: Ethnicity HL7 Value
+78 ; ^04: Ethnicity
+79 ; ^05: Collection Method HL7 value
+80 ; ^06: Collection Method
+81 ;
+82 ; Ethnicity HL7 Values
+83 ; 0000-0 Declined to Answer
+84 ; 2135-2 Hispanic or Latino
+85 ; 2186-5 Not Hispanic or Latino
+86 ; 9999-4 Unknown by Patient
+87 ;
+88 ; RESULTS(i) Patient's Registry Data
+89 ; ^01: "PRD"
+90 ; ^02: ""
+91 ; ... See the $$LOAD798^RORRP020
+92 ;
+93 ; RESULTS(i) Local field data
+94 ; ^O1: "LFV"
+95 ; ^02: IEN in the LOCAL FIELD multiple
+96 ; of the ROR REGISTRY RECORD file
+97 ; ^03: Field Definition IEN
+98 ; (in the ROR LOCAL FIELD file)
+99 ; ^04: Field Name
+100 ; ^05: Date (FileMan)
+101 ; ^06: Comment
+102 ;
+103 ; RESULTS(i) Selection Rule
+104 ; ^01: "PSR"
+105 ; ^02: IEN in the SELECTION RULE multiple
+106 ; of the ROR REGISTRY RECORD file
+107 ; ^03: Rule Definition IEN
+108 ; (in the ROR SELECTION RULE file)
+109 ; ^04: Name of the Rule
+110 ; ^05: Date (FileMan)
+111 ; ^06: Location IEN (Institution IEN)
+112 ; ^07: Location Name (Institution Name)
+113 ; ^08: Short Description
+114 ;
GETPTDAT(RESULTS,PTIEN,FLAGS,REGIEN) ;
+1 NEW BUF,BUF1,DOD,IEN,RC,RESPTR,RORERRDL,VADM
+2 DO CLEAR^RORERR("GETPTDAT^RORRP021",1)
+3 KILL RESULTS
SET (RESULTS(0),RESPTR)=0
+4 ;=== Check the parameters
+5 SET RC=0
Begin DoDot:1
+6 ;--- Patient IEN
+7 IF $GET(PTIEN)'>0
Begin DoDot:2
+8 SET RC=$$ERROR^RORERR(-88,,,,"PTIEN",$GET(PTIEN))
End DoDot:2
QUIT
+9 SET PTIEN=+PTIEN
+10 ;--- Flags
+11 SET FLAGS=$$UP^XLFSTR($GET(FLAGS))
End DoDot:1
IF RC<0
DO RPCSTK^RORERR(.RESULTS,RC)
QUIT
+12 ;=== Load the data from the PATIENT file
+13 SET RC=$$LOAD2^RORRP020(PTIEN,.BUF,.BUF1,.VADM)
+14 IF RC<0
DO RPCSTK^RORERR(.RESULTS,RC)
QUIT
+15 SET DOD=$PIECE(BUF,U,5)
+16 ;
+17 ;=== Demographic information and address
+18 SET RESPTR=RESPTR+1
SET RESULTS(RESPTR)="DEM^^"_BUF
+19 if FLAGS["A"
SET RESPTR=RESPTR+1
SET RESULTS(RESPTR)="ADR^^"_BUF1
+20 ;
+21 ;=== Race information
+22 IF FLAGS["R"
if $GET(VADM(12))>0
Begin DoDot:1
+23 NEW I,METHOD,RACE
+24 SET I=""
+25 FOR
SET I=$ORDER(VADM(12,I))
if I=""
QUIT
Begin DoDot:2
+26 SET RACE=$GET(VADM(12,I))
if RACE'>0
QUIT
+27 SET METHOD=$GET(VADM(12,I,1))
+28 SET BUF="RCE"_U_(+RACE)
+29 ;---
+30 SET $PIECE(BUF,U,3)=$$PTR2CODE^DGUTL4(+RACE,1,2)
+31 SET $PIECE(BUF,U,4)=$PIECE(RACE,U,2)
+32 SET $PIECE(BUF,U,5)=$$PTR2CODE^DGUTL4(+METHOD,3,2)
+33 SET $PIECE(BUF,U,6)=$PIECE(METHOD,U,2)
+34 ;---
+35 SET RESPTR=RESPTR+1
SET RESULTS(RESPTR)=BUF
End DoDot:2
End DoDot:1
+36 ;
+37 ;=== Ethnicity information
+38 IF FLAGS["E"
if $GET(VADM(11))>0
Begin DoDot:1
+39 NEW ETHN,I,METHOD
+40 SET I=""
+41 FOR
SET I=$ORDER(VADM(11,I))
if I=""
QUIT
Begin DoDot:2
+42 SET ETHN=$GET(VADM(11,I))
if ETHN'>0
QUIT
+43 SET METHOD=$GET(VADM(11,I,1))
+44 SET BUF="ETN"_U_(+ETHN)
+45 ;---
+46 SET $PIECE(BUF,U,3)=$$PTR2CODE^DGUTL4(+ETHN,2,2)
+47 SET $PIECE(BUF,U,4)=$PIECE(ETHN,U,2)
+48 SET $PIECE(BUF,U,5)=$$PTR2CODE^DGUTL4(+METHOD,3,2)
+49 SET $PIECE(BUF,U,6)=$PIECE(METHOD,U,2)
+50 ;---
+51 SET RESPTR=RESPTR+1
SET RESULTS(RESPTR)=BUF
End DoDot:2
End DoDot:1
+52 ;
+53 ;=== Patient's registry data
+54 IF $GET(REGIEN)>0
Begin DoDot:1
+55 SET RESPTR=RESPTR+1
+56 ;--- Get the IEN of the registry record
+57 SET IEN=$$PRRIEN^RORUTL01(PTIEN,REGIEN)
+58 IF IEN'>0
SET RESULTS(RESPTR)="PRD"
QUIT
+59 ;--- Load the data from the patient's registry record
+60 SET RC=$$LOAD798^RORRP020(IEN,.BUF,DOD)
if RC<0
QUIT
+61 SET RESULTS(RESPTR)="PRD^^"_BUF
+62 ;--- Local field values
+63 IF FLAGS["L"
Begin DoDot:2
+64 SET RC=$$LFV(IEN,.RESULTS,.RESPTR)
End DoDot:2
if RC<0
QUIT
+65 ;--- Selection rules
+66 IF FLAGS["S"
Begin DoDot:2
+67 SET RC=$$PSR(IEN,.RESULTS,.RESPTR)
End DoDot:2
if RC<0
QUIT
End DoDot:1
IF RC<0
DO RPCSTK^RORERR(.RESULTS,RC)
QUIT
+68 ;===
+69 QUIT
+70 ;
+71 ;***** GET THE LOCAL FIELD VALUES
LFV(IEN798,RESULTS,RESPTR) ;
+1 NEW I,IEN,IENS,RORBUF,SCR,RORMSG
+2 SET DT=$$DT^XLFDT
+3 ;--- Load the data
+4 SET SCR="I $$LFACTIVE^RORDD01(+$G(^(0)))"
+5 SET IENS=","_IEN798_","
SET I="@;.01I;.01E;.02I;1"
+6 DO LIST^DIC(798.02,IENS,I,"P",,,,"B",SCR,,"RORBUF","RORMSG")
+7 if $GET(DIERR)
QUIT $$DBS^RORERR("RORMSG",-9,,,798.02,IENS)
+8 ;--- Add the data to the output array
+9 SET I=0
+10 FOR
SET I=$ORDER(RORBUF("DILIST",I))
if I'>0
QUIT
Begin DoDot:1
+11 SET RESPTR=RESPTR+1
+12 SET RESULTS(RESPTR)="LFV^"_RORBUF("DILIST",I,0)
End DoDot:1
+13 ;--- Success
+14 QUIT 0
+15 ;
+16 ;***** GET THE SELECTION RULES
PSR(IEN798,RESULTS,RESPTR) ;
+1 NEW BUF,I,IEN,IENS,RORBUF,RORMSG,TMP
+2 ;--- Load the data
+3 SET IENS=","_IEN798_","
SET TMP="@;.01I;.01E;1I;2I;2E"
+4 DO LIST^DIC(798.01,IENS,TMP,"P",,,,"AD",,,"RORBUF","RORMSG")
+5 if $GET(DIERR)
QUIT $$DBS^RORERR("RORMSG",-9,,,798.01,IENS)
+6 ;--- Add the data to the output array
+7 SET I=0
+8 FOR
SET I=$ORDER(RORBUF("DILIST",I))
if I'>0
QUIT
Begin DoDot:1
+9 SET BUF=RORBUF("DILIST",I,0)
SET IEN=+$PIECE(BUF,U,2)
if IEN'>0
QUIT
+10 SET TMP=$$GET1^DIQ(798.2,IEN_",",4,,,"RORMSG")
+11 if $GET(DIERR)
DO DBS^RORERR("RORMSG",-9,,,798.2,IEN_",")
+12 SET $PIECE(BUF,U,7)=$SELECT(TMP'="":TMP,1:$PIECE(BUF,U,3))
+13 SET RESPTR=RESPTR+1
SET RESULTS(RESPTR)="PSR^"_BUF
End DoDot:1
+14 ;--- Success
+15 QUIT 0
