RORHL03 ;HOIFO/CRT - HL7 PHARMACY: ORC,RXE ; 5/30/06 8:35am
;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
;
; Routines RORHL03* use the following IAs:
;
; #93-A Get stop code from the file #44 (controlled)
; #1876 Read access to file #59
; #2400 OCL^PSOORRL and OEL^PSOORRL (controlled)
; #4820 RX^PSO52API (supported)
; #4826 PSS432^PSS55 and PSS436^PSS55 (supported)
; #10060 Read access to file #200 (supported)
; #10090 Read access to file #4 (supported)
;
Q
;
;***** PHARMACY DATA SEGMENT BUILDER
;
; RORDFN DFN of Patient Record in File #2
;
; .DXDTS Reference to a local variable where the
; data extraction time frames are stored.
;
; Return Values:
; <0 Error Code
; 0 Ok
; >0 Non-fatal error(s)
;
; The ^TMP("PS",$J) global node is used by this function.
;
EN1(RORDFN,DXDTS) ;
N ENDT,ERRCNT,IDX,RC,STDT
S (ERRCNT,RC)=0
;---
S IDX=0
F S IDX=$O(DXDTS(6,IDX)) Q:IDX'>0 D Q:RC<0
. S STDT=$P(DXDTS(6,IDX),U),ENDT=$P(DXDTS(6,IDX),U,2)
. S TMP=$$EN2(RORDFN,STDT,ENDT)
. I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
;---
Q $S(RC<0:RC,1:ERRCNT)
;
;***** PHARMACY DATA SEGMENT BUILDER
;
; RORDFN DFN of Patient Record in File #2
;
; RORSTDT Start Date/Time (Fileman)
; RORENDT End Date/Time (Fileman)
;
; Return Values:
; <0 Error Code
; 0 Ok
; >0 Non-fatal error(s)
;
EN2(RORDFN,RORSTDT,RORENDT) ;
N ERRCNT,IEN55,II,RC,ROR55,ROR55SUB,RORII,RORINC,RORINDEX,RORMSG,RORORD,RORRXE,RORTMP,RORXII,TMP
S (ERRCNT,RC)=0
;
;--- Load the list of prescriptions
K ^TMP("PS",$J)
D OCL^PSOORRL(RORDFN,RORSTDT,RORENDT)
Q:$D(^TMP("PS",$J))<10 0
;
;--- Select the prescriptions
S RORTMP=$$ALLOC^RORTMP()
S RORII=0
F S RORII=$O(^TMP("PS",$J,RORII)) Q:'RORII D
. S RORORD=$P(^TMP("PS",$J,RORII,0),U)
. Q:RORORD'>0
. S II=$P(RORORD,";"),II=$E(II,$L(II))
. Q:'("RUV"[II)
. ;---
. I "UV"[II D Q:(TMP<RORSTDT)!(TMP'<RORENDT)
. . S TMP=$P($G(^TMP("PS",$J,RORII,0)),U,15)
. I II="R" D Q:TMP<RORSTDT
. . S TMP=$P($G(^TMP("PS",$J,RORII,0)),U,10)
. ;---
. S @RORTMP@(RORII,0)=^TMP("PS",$J,RORII,0)
K ^TMP("PS",$J)
;
;--- Browse through the list and generate the HL7 segments
S ROR55=$$ALLOC^RORTMP(.ROR55SUB)
S RORII=0
F S RORII=$O(@RORTMP@(RORII)) Q:'RORII D Q:RC<0
. S RORORD=$P(@RORTMP@(RORII,0),U)
. S RORXII=$P(RORORD,";"),RORXII=$E(RORXII,$L(RORXII))
. S IEN55=+$P(RORORD,";")
. ;
. K ^TMP("PS",$J),RORRXE
. D OEL^PSOORRL(RORDFN,RORORD)
. Q:$D(^TMP("PS",$J))<10
. M RORRXE=^TMP("PS",$J)
. K ^TMP("PS",$J)
. ;
. I RORXII="R" D ;--- Outpatient Pharmacy
. . D REFILL
. . ;--- Check if the original prescription or one of
. . ;--- the refills is within date range
. . S RORINC=0
. . F RORINDEX="REF","PAR" D
. . . S II=""
. . . F S II=$O(RORRXE(RORINDEX,II)) Q:II="" D
. . . . S TMP=$P($G(RORRXE(RORINDEX,II,0)),U)
. . . . I TMP'<RORSTDT,TMP<RORENDT S RORINC=1 Q
. . . . K RORRXE(RORINDEX,II,0)
. . Q:'RORINC
. . ;---
. . S TMP=$$ORC(IEN55,.RORRXE,RORDFN)
. . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
. . S TMP=$$RXE^RORHL031(IEN55,.RORRXE,RORDFN)
. . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
. . ;
. I RORXII="U" D ;--- Unit Dose Inpatient Pharmacy
. . N NODE K @ROR55
. . D PSS432^PSS55(RORDFN,IEN55,ROR55SUB)
. . S NODE=$NA(@ROR55@(IEN55))
. . ;---
. . S TMP=$$ORC^RORHL07(NODE,.RORRXE)
. . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
. . S TMP=$$RXE^RORHL07(NODE,.RORRXE)
. . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
. . ;
. I RORXII="V" D ;--- IV Inpatient Pharmacy
. . N NODE K @ROR55
. . D PSS436^PSS55(RORDFN,IEN55,ROR55SUB)
. . S NODE=$NA(@ROR55@(IEN55))
. . ;---
. . S TMP=$$ORC^RORHL071(NODE,.RORRXE)
. . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
. . S TMP=$$RXE^RORHL071(NODE,.RORRXE)
. . I TMP Q:TMP<0 S ERRCNT=ERRCNT+TMP
;
D FREE^RORTMP(ROR55),FREE^RORTMP(RORTMP)
Q $S(RC<0:RC,1:ERRCNT)
;
;***** OUTPATIENT PHARMACY ORC SEGMENT BUILDER
;
; RORIEN IEN of the record of the PRESCRIPTION file (#52)
;
; .RORORC Array with info (from OEL^PSOORRL)
;
; PTIEN Patient IEN (DFN)
;
; Return Values:
; <0 Error Code
; 0 Ok
; >0 Non-fatal error(s)
;
ORC(RORIEN,RORORC,PTIEN) ;
N BUF,CS,ERRCNT,IEN,IENS59,RC,RORMSG,ROROUT,RORSEG,RORTMP,RORTS,TMP
S (ERRCNT,RC)=0
D ECH^RORHL7(.CS)
;
;--- Initialize the segment
S RORSEG(0)="ORC"
;
;--- ORC-1 - Order Control
S RORSEG(1)="NW"
;
;--- ORC-2 - Placer Order #
S RORSEG(2)=+RORIEN_CS_"OP"
;
;--- ORC-9 - Release Date/Time
S TMP=$P($G(RORORC("RXN",0)),U,7)
S RORSEG(9)=$$FM2HL^RORHL7(TMP)
;
;--- ORC-12 - Provider
S BUF=+$P($G(RORORC("P",0)),U)
I BUF>0 D
. S $P(BUF,CS,13)=$$GET1^DIQ(200,+BUF_",",53.5,"E",,"RORMSG")
. I $G(DIERR) D S ERRCNT=ERRCNT+1
. . D DBS^RORERR("RORMSG",-99,,,200,+BUF_",")
. S RORSEG(12)=BUF
;
;--- ORC-15 - Order Date/Time
S TMP=$$FMTHL7^XLFDT($P($G(RORORC(0)),U,5))
Q:TMP'>0 $$ERROR^RORERR(-100,,,,"No order date","OEL^PSOORRL")
S RORSEG(15)=TMP
;
;--- ORC-16 - Control Code Reason
S RORSEG(16)=CS_CS_CS_CS_"NEW"
;
;--- ORC-17 - Division
S RORSEG(17)=$$SITE^RORUTL03(CS)
S RORTMP=$$ALLOC^RORTMP(.RORTS)
D RX^PSO52API(PTIEN,RORTS,+RORIEN,,"2")
S IENS59=+$G(@RORTMP@(PTIEN,+RORIEN,20))_","
D FREE^RORTMP(RORTMP)
I IENS59>0 D
. D GETS^DIQ(59,IENS59,"100","IE","ROROUT","RORMSG")
. I $G(DIERR) D S ERRCNT=ERRCNT+1 Q
. . D DBS^RORERR("RORMSG",-99,,,59,IENS59)
. S IEN=+$G(ROROUT(59,IENS59,100,"I"))
. Q:IEN'>0
. ;---
. S BUF=$$GET1^DIQ(4,IEN_",",99,"I",,"RORMSG")
. I $G(DIERR) D S ERRCNT=ERRCNT+1 Q
. . D DBS^RORERR("RORMSG",-99,,,4,IEN_",")
. Q:BUF=""
. S $P(BUF,CS,2)=$$ESCAPE^RORHL7($G(ROROUT(59,IENS59,100,"E")))
. S $P(BUF,CS,3)="99VA4"
. S RORSEG(17)=BUF
;
;--- Store the segment
D ADDSEG^RORHL7(.RORSEG)
Q ERRCNT
;
;***** MAKES ORIGINAL FILL LIKE REFILLS TO REUSE CODE
REFILL ;
S RORRXE("REF",0,0)=""
S $P(RORRXE("REF",0,0),U,1)=$P(RORRXE("RXN",0),U,6)
S $P(RORRXE("REF",0,0),U,2)=$P(RORRXE(0),U,7)
S $P(RORRXE("REF",0,0),U,3)=$P(RORRXE(0),U,8)
S $P(RORRXE("REF",0,0),U,4)=$P(RORRXE("RXN",0),U,7)
S $P(RORRXE("REF",0,0),U,5)=$P(RORRXE("RXN",0),U,3)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORHL03 6467 printed Sep 23, 2025@19:17:44 Page 2
RORHL03 ;HOIFO/CRT - HL7 PHARMACY: ORC,RXE ; 5/30/06 8:35am
+1 ;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
+2 ;
+3 ; Routines RORHL03* use the following IAs:
+4 ;
+5 ; #93-A Get stop code from the file #44 (controlled)
+6 ; #1876 Read access to file #59
+7 ; #2400 OCL^PSOORRL and OEL^PSOORRL (controlled)
+8 ; #4820 RX^PSO52API (supported)
+9 ; #4826 PSS432^PSS55 and PSS436^PSS55 (supported)
+10 ; #10060 Read access to file #200 (supported)
+11 ; #10090 Read access to file #4 (supported)
+12 ;
+13 QUIT
+14 ;
+15 ;***** PHARMACY DATA SEGMENT BUILDER
+16 ;
+17 ; RORDFN DFN of Patient Record in File #2
+18 ;
+19 ; .DXDTS Reference to a local variable where the
+20 ; data extraction time frames are stored.
+21 ;
+22 ; Return Values:
+23 ; <0 Error Code
+24 ; 0 Ok
+25 ; >0 Non-fatal error(s)
+26 ;
+27 ; The ^TMP("PS",$J) global node is used by this function.
+28 ;
EN1(RORDFN,DXDTS) ;
+1 NEW ENDT,ERRCNT,IDX,RC,STDT
+2 SET (ERRCNT,RC)=0
+3 ;---
+4 SET IDX=0
+5 FOR
SET IDX=$ORDER(DXDTS(6,IDX))
if IDX'>0
QUIT
Begin DoDot:1
+6 SET STDT=$PIECE(DXDTS(6,IDX),U)
SET ENDT=$PIECE(DXDTS(6,IDX),U,2)
+7 SET TMP=$$EN2(RORDFN,STDT,ENDT)
+8 IF TMP
if TMP<0
QUIT
SET ERRCNT=ERRCNT+TMP
End DoDot:1
if RC<0
QUIT
+9 ;---
+10 QUIT $SELECT(RC<0:RC,1:ERRCNT)
+11 ;
+12 ;***** PHARMACY DATA SEGMENT BUILDER
+13 ;
+14 ; RORDFN DFN of Patient Record in File #2
+15 ;
+16 ; RORSTDT Start Date/Time (Fileman)
+17 ; RORENDT End Date/Time (Fileman)
+18 ;
+19 ; Return Values:
+20 ; <0 Error Code
+21 ; 0 Ok
+22 ; >0 Non-fatal error(s)
+23 ;
EN2(RORDFN,RORSTDT,RORENDT) ;
+1 NEW ERRCNT,IEN55,II,RC,ROR55,ROR55SUB,RORII,RORINC,RORINDEX,RORMSG,RORORD,RORRXE,RORTMP,RORXII,TMP
+2 SET (ERRCNT,RC)=0
+3 ;
+4 ;--- Load the list of prescriptions
+5 KILL ^TMP("PS",$JOB)
+6 DO OCL^PSOORRL(RORDFN,RORSTDT,RORENDT)
+7 if $DATA(^TMP("PS",$JOB))<10
QUIT 0
+8 ;
+9 ;--- Select the prescriptions
+10 SET RORTMP=$$ALLOC^RORTMP()
+11 SET RORII=0
+12 FOR
SET RORII=$ORDER(^TMP("PS",$JOB,RORII))
if 'RORII
QUIT
Begin DoDot:1
+13 SET RORORD=$PIECE(^TMP("PS",$JOB,RORII,0),U)
+14 if RORORD'>0
QUIT
+15 SET II=$PIECE(RORORD,";")
SET II=$EXTRACT(II,$LENGTH(II))
+16 if '("RUV"[II)
QUIT
+17 ;---
+18 IF "UV"[II
Begin DoDot:2
+19 SET TMP=$PIECE($GET(^TMP("PS",$JOB,RORII,0)),U,15)
End DoDot:2
if (TMP<RORSTDT)!(TMP'<RORENDT)
QUIT
+20 IF II="R"
Begin DoDot:2
+21 SET TMP=$PIECE($GET(^TMP("PS",$JOB,RORII,0)),U,10)
End DoDot:2
if TMP<RORSTDT
QUIT
+22 ;---
+23 SET @RORTMP@(RORII,0)=^TMP("PS",$JOB,RORII,0)
End DoDot:1
+24 KILL ^TMP("PS",$JOB)
+25 ;
+26 ;--- Browse through the list and generate the HL7 segments
+27 SET ROR55=$$ALLOC^RORTMP(.ROR55SUB)
+28 SET RORII=0
+29 FOR
SET RORII=$ORDER(@RORTMP@(RORII))
if 'RORII
QUIT
Begin DoDot:1
+30 SET RORORD=$PIECE(@RORTMP@(RORII,0),U)
+31 SET RORXII=$PIECE(RORORD,";")
SET RORXII=$EXTRACT(RORXII,$LENGTH(RORXII))
+32 SET IEN55=+$PIECE(RORORD,";")
+33 ;
+34 KILL ^TMP("PS",$JOB),RORRXE
+35 DO OEL^PSOORRL(RORDFN,RORORD)
+36 if $DATA(^TMP("PS",$JOB))<10
QUIT
+37 MERGE RORRXE=^TMP("PS",$JOB)
+38 KILL ^TMP("PS",$JOB)
+39 ;
+40 ;--- Outpatient Pharmacy
IF RORXII="R"
Begin DoDot:2
+41 DO REFILL
+42 ;--- Check if the original prescription or one of
+43 ;--- the refills is within date range
+44 SET RORINC=0
+45 FOR RORINDEX="REF","PAR"
Begin DoDot:3
+46 SET II=""
+47 FOR
SET II=$ORDER(RORRXE(RORINDEX,II))
if II=""
QUIT
Begin DoDot:4
+48 SET TMP=$PIECE($GET(RORRXE(RORINDEX,II,0)),U)
+49 IF TMP'<RORSTDT
IF TMP<RORENDT
SET RORINC=1
QUIT
+50 KILL RORRXE(RORINDEX,II,0)
End DoDot:4
End DoDot:3
+51 if 'RORINC
QUIT
+52 ;---
+53 SET TMP=$$ORC(IEN55,.RORRXE,RORDFN)
+54 IF TMP
if TMP<0
QUIT
SET ERRCNT=ERRCNT+TMP
+55 SET TMP=$$RXE^RORHL031(IEN55,.RORRXE,RORDFN)
+56 IF TMP
if TMP<0
QUIT
SET ERRCNT=ERRCNT+TMP
+57 ;
End DoDot:2
+58 ;--- Unit Dose Inpatient Pharmacy
IF RORXII="U"
Begin DoDot:2
+59 NEW NODE
KILL @ROR55
+60 DO PSS432^PSS55(RORDFN,IEN55,ROR55SUB)
+61 SET NODE=$NAME(@ROR55@(IEN55))
+62 ;---
+63 SET TMP=$$ORC^RORHL07(NODE,.RORRXE)
+64 IF TMP
if TMP<0
QUIT
SET ERRCNT=ERRCNT+TMP
+65 SET TMP=$$RXE^RORHL07(NODE,.RORRXE)
+66 IF TMP
if TMP<0
QUIT
SET ERRCNT=ERRCNT+TMP
+67 ;
End DoDot:2
+68 ;--- IV Inpatient Pharmacy
IF RORXII="V"
Begin DoDot:2
+69 NEW NODE
KILL @ROR55
+70 DO PSS436^PSS55(RORDFN,IEN55,ROR55SUB)
+71 SET NODE=$NAME(@ROR55@(IEN55))
+72 ;---
+73 SET TMP=$$ORC^RORHL071(NODE,.RORRXE)
+74 IF TMP
if TMP<0
QUIT
SET ERRCNT=ERRCNT+TMP
+75 SET TMP=$$RXE^RORHL071(NODE,.RORRXE)
+76 IF TMP
if TMP<0
QUIT
SET ERRCNT=ERRCNT+TMP
End DoDot:2
End DoDot:1
if RC<0
QUIT
+77 ;
+78 DO FREE^RORTMP(ROR55)
DO FREE^RORTMP(RORTMP)
+79 QUIT $SELECT(RC<0:RC,1:ERRCNT)
+80 ;
+81 ;***** OUTPATIENT PHARMACY ORC SEGMENT BUILDER
+82 ;
+83 ; RORIEN IEN of the record of the PRESCRIPTION file (#52)
+84 ;
+85 ; .RORORC Array with info (from OEL^PSOORRL)
+86 ;
+87 ; PTIEN Patient IEN (DFN)
+88 ;
+89 ; Return Values:
+90 ; <0 Error Code
+91 ; 0 Ok
+92 ; >0 Non-fatal error(s)
+93 ;
ORC(RORIEN,RORORC,PTIEN) ;
+1 NEW BUF,CS,ERRCNT,IEN,IENS59,RC,RORMSG,ROROUT,RORSEG,RORTMP,RORTS,TMP
+2 SET (ERRCNT,RC)=0
+3 DO ECH^RORHL7(.CS)
+4 ;
+5 ;--- Initialize the segment
+6 SET RORSEG(0)="ORC"
+7 ;
+8 ;--- ORC-1 - Order Control
+9 SET RORSEG(1)="NW"
+10 ;
+11 ;--- ORC-2 - Placer Order #
+12 SET RORSEG(2)=+RORIEN_CS_"OP"
+13 ;
+14 ;--- ORC-9 - Release Date/Time
+15 SET TMP=$PIECE($GET(RORORC("RXN",0)),U,7)
+16 SET RORSEG(9)=$$FM2HL^RORHL7(TMP)
+17 ;
+18 ;--- ORC-12 - Provider
+19 SET BUF=+$PIECE($GET(RORORC("P",0)),U)
+20 IF BUF>0
Begin DoDot:1
+21 SET $PIECE(BUF,CS,13)=$$GET1^DIQ(200,+BUF_",",53.5,"E",,"RORMSG")
+22 IF $GET(DIERR)
Begin DoDot:2
+23 DO DBS^RORERR("RORMSG",-99,,,200,+BUF_",")
End DoDot:2
SET ERRCNT=ERRCNT+1
+24 SET RORSEG(12)=BUF
End DoDot:1
+25 ;
+26 ;--- ORC-15 - Order Date/Time
+27 SET TMP=$$FMTHL7^XLFDT($PIECE($GET(RORORC(0)),U,5))
+28 if TMP'>0
QUIT $$ERROR^RORERR(-100,,,,"No order date","OEL^PSOORRL")
+29 SET RORSEG(15)=TMP
+30 ;
+31 ;--- ORC-16 - Control Code Reason
+32 SET RORSEG(16)=CS_CS_CS_CS_"NEW"
+33 ;
+34 ;--- ORC-17 - Division
+35 SET RORSEG(17)=$$SITE^RORUTL03(CS)
+36 SET RORTMP=$$ALLOC^RORTMP(.RORTS)
+37 DO RX^PSO52API(PTIEN,RORTS,+RORIEN,,"2")
+38 SET IENS59=+$GET(@RORTMP@(PTIEN,+RORIEN,20))_","
+39 DO FREE^RORTMP(RORTMP)
+40 IF IENS59>0
Begin DoDot:1
+41 DO GETS^DIQ(59,IENS59,"100","IE","ROROUT","RORMSG")
+42 IF $GET(DIERR)
Begin DoDot:2
+43 DO DBS^RORERR("RORMSG",-99,,,59,IENS59)
End DoDot:2
SET ERRCNT=ERRCNT+1
QUIT
+44 SET IEN=+$GET(ROROUT(59,IENS59,100,"I"))
+45 if IEN'>0
QUIT
+46 ;---
+47 SET BUF=$$GET1^DIQ(4,IEN_",",99,"I",,"RORMSG")
+48 IF $GET(DIERR)
Begin DoDot:2
+49 DO DBS^RORERR("RORMSG",-99,,,4,IEN_",")
End DoDot:2
SET ERRCNT=ERRCNT+1
QUIT
+50 if BUF=""
QUIT
+51 SET $PIECE(BUF,CS,2)=$$ESCAPE^RORHL7($GET(ROROUT(59,IENS59,100,"E")))
+52 SET $PIECE(BUF,CS,3)="99VA4"
+53 SET RORSEG(17)=BUF
End DoDot:1
+54 ;
+55 ;--- Store the segment
+56 DO ADDSEG^RORHL7(.RORSEG)
+57 QUIT ERRCNT
+58 ;
+59 ;***** MAKES ORIGINAL FILL LIKE REFILLS TO REUSE CODE
REFILL ;
+1 SET RORRXE("REF",0,0)=""
+2 SET $PIECE(RORRXE("REF",0,0),U,1)=$PIECE(RORRXE("RXN",0),U,6)
+3 SET $PIECE(RORRXE("REF",0,0),U,2)=$PIECE(RORRXE(0),U,7)
+4 SET $PIECE(RORRXE("REF",0,0),U,3)=$PIECE(RORRXE(0),U,8)
+5 SET $PIECE(RORRXE("REF",0,0),U,4)=$PIECE(RORRXE("RXN",0),U,7)
+6 SET $PIECE(RORRXE("REF",0,0),U,5)=$PIECE(RORRXE("RXN",0),U,3)
+7 QUIT
