RORUTL15 ;HCIOFO/BH,SG - PHARMACY DATA SEARCH (TOOLS) ; 04 Apr 2016 4:57 PM
;;1.5;CLINICAL CASE REGISTRIES;**13,26,28**;Feb 17, 2006;Build 66
;
; This routine uses the following IAs:
;
; #2400 OCL^PSOORRL and OEL^PSOORRL (controlled)
; #4533 ARWS^PSS50 (supported)
; #4543 IEN^PSN50P65 (supported)
; #4549 ZERO^PSS52P6 (supported)
; #4826 PSS436^PSS55 (supported)
; #10104 UP^XLFSTR (supported)
;
;******************************************************************************
;******************************************************************************
; --- ROUTINE MODIFICATION LOG ---
;
;PKG/PATCH DATE DEVELOPER MODIFICATION
;----------- ---------- ----------- ----------------------------------------
;ROR*1.5*13 DEC 2010 A SAUNDERS Patient Med History Report: retrieve
; #refills remaining and add to the
; 'callback' function call
; NOTE: Patch 11 became patch 13.
; Any references to patch 11 in the code
; below is referring to path 13.
;
;ROR*1.5*26 JUN 2015 T KOPP Callback function for SVR screening
; does not require the # of refills as a
; parameter for the Patient Med History
; Report, so a check is made for callback
; entry point RXOCB to prevent adding it.
;
;ROR*1.5*28 APR 2016 T KOPP Check for DAA drug/in house param
;******************************************************************************
;******************************************************************************
Q
;
;***** DOUBLE-CHECKS THE OUTPATIENT RX (ORDER, REFILLS AND PARTIALS)
;
; STDT Start Date (FileMan)
; ENDT End Date (FileMan)
;
; [.NREF] Number of refills is returned via this parameter
;
; [.NPAR] Nubmer of partials is returned via this parameter
;
; The ^TMP("PS",$J) node must be populated by the OEL^PSOORRL
; before calling this function.
;
; Return Values:
; 0 Ok
; 1 Skip the order
;
DTCHECK(STDT,ENDT,NREF,NPAR) ;
N IRP,RXDT,SKIP
S RXDT=+$P($G(^TMP("PS",$J,"RXN",0)),U,6),(NREF,NPAR)=0
S SKIP=(RXDT<STDT)!(RXDT'<ENDT)
;--- Refills
S IRP=0
F S IRP=$O(^TMP("PS",$J,"REF",IRP)) Q:IRP'>0 D
. S RXDT=+$P($G(^TMP("PS",$J,"REF",IRP,0)),U)
. I RXDT'<STDT,RXDT<ENDT S SKIP=0,NREF=NREF+1 Q
. K ^TMP("PS",$J,"REF",IRP)
;--- Partials
S IRP=0
F S IRP=$O(^TMP("PS",$J,"PAR",IRP)) Q:IRP'>0 D
. S RXDT=+$P($G(^TMP("PS",$J,"PAR",IRP,0)),U)
. I RXDT'<STDT,RXDT<ENDT S SKIP=0,NPAR=NPAR+1 Q
. K ^TMP("PS",$J,"PAR",IRP)
;---
Q SKIP
;
;***** PROCESSES THE LIST OF PRESELECTED PHARMACY ORDERS
;
; PTIEN IEN of the patient (DFN)
;
; RORFLAGS Flags to control processing
;
; ROR8LST Closed root of the list of preselected orders
;
; Return Values:
; <0 Error code
; 0 No orders have been found
; >0 Number of orders
;
PROCESS(PTIEN,RORFLAGS,ROR8LST) ;
N DRUGIEN,IRX,IVM,LOADEXT,ORDDATE,ORDER,ORDIEN,ORDFLG,RC,ROR8SET,RORLST,RORTMP,RORTS,RORXCNT,TMP,NUMREF
S LOADEXT=(RORFLAGS["E")
S (RC,RORXCNT)=0
S RORTMP=$$ALLOC^RORTMP(.RORTS)
;
;=== Determine the storage method (default or callback)
I $G(ROR8DST("RORCB"))?2"$"1.8UN1"^"1.8UN D
. ;standard callback setup
. S ROR8SET="S RC="_ROR8DST("RORCB")_"(.ROR8DST,ORDER"
. S ROR8SET=ROR8SET_",ORDFLG,DRUGIEN_U_DRUGNAME,ORDDATE)"
. ;Patch 11/13: Variable 'RORX011' is set in routine RORX011 for the
. ;Patient Medications History report. If set, add # refills
. ;remaining (NUMREF) to the callback parameter list.
. I $G(RORX011),$G(ROR8DST("RORCB"))'["RXOCB" S ROR8SET=$E(ROR8SET,1,$L(ROR8SET)-1)_",$G(NUMREF))"
. ;---
. S ROR8DST("RORDFN")=PTIEN
. S ROR8DST("ROREDT")=ROREDT
. S ROR8DST("RORFLAGS")=RORFLAGS
. S ROR8DST("RORSDT")=RORSDT
E S ROR8SET="" K @ROR8DST
;
;=== Process the list of preselected orders
S (IRX,RC)=0
F S IRX=$O(@ROR8LST@(IRX)) Q:'IRX D Q:RC
. N REMARK,CHOICE
. S ORDFLG=$P(@ROR8LST@(IRX),U)
. S TMP=@ROR8LST@(IRX,0)
. S ORDER=$P(TMP,U),ORDDATE=$P(TMP,U,15)
. ;Patch 11/13: get #refills remaining for Patient Medication History report:
. I $G(RORX011) S NUMREF=$P(TMP,U,5)
. ;--- Get the order details
. K ^TMP("PS",$J)
. D OEL^PSOORRL(PTIEN,ORDER)
. Q:$D(^TMP("PS",$J))<10
. ; Check order remark for "CHOICE"
. I RORFLAGS["C"!(RORFLAGS["H") D Q:$S(RORFLAGS["C":'CHOICE,RORFLAGS["H":CHOICE,1:0)
. . S REMARK=$$UP^XLFSTR($P($G(^TMP("PS",$J,"RXN",0)),U,4))
. . S CHOICE=(REMARK["CHOICE") ; true if DAA drug, false if in house
. ;=== Inpatient and Outpatient Medications
. I ORDFLG'["V" D Q
. . ;--- Double-check the dates for outpatient orders
. . I ORDFLG["O" Q:$$DTCHECK(RORSDT,ROREDT)
. . ;--- Get the drug IEN in the DRUG file (#50)
. . S TMP=$G(^TMP("PS",$J,"DD",1,0)),DRUGIEN=+$P(TMP,U,3)
. . I DRUGIEN'>0 S DRUGIEN=+$P(TMP,U) Q:DRUGIEN'>0
. . ;--- Process the order
. . S RC=$$PROCMED(ORDER,ORDFLG,DRUGIEN,ORDDATE)
. . S:'RC RORXCNT=RORXCNT+1
. . S:RC=1 RC=0
. ;=== IV Medications
. S RORLST=$$ALLOC^RORTMP(.TMP),ORDIEN=+ORDER
. D
. . N IEN,ORDER ; Workaround for the bug in the API
. . D PSS436^PSS55(PTIEN,ORDIEN,TMP)
. I $G(@RORLST@(0))'>0 D FREE^RORTMP(RORLST) Q
. ;--- Process the additives
. S IVM=0
. F S IVM=$O(@RORLST@(ORDIEN,"ADD",IVM)) Q:IVM'>0 D Q:RC
. . ;--- IEN in the IV ADDITIVES file (#52.6)
. . S DRUGIEN=+$P($G(@RORLST@(ORDIEN,"ADD",IVM,.01)),U)
. . Q:DRUGIEN'>0
. . ;--- IEN in the DRUG file (#50)
. . D ZERO^PSS52P6(DRUGIEN,,,RORTS)
. . Q:$G(@RORTMP@(0))'>0
. . S DRUGIEN=+$P($G(@RORTMP@(DRUGIEN,1)),U)
. . Q:DRUGIEN'>0
. . ;--- Process the medication
. . S RC=$$PROCMED(ORDER,ORDFLG,DRUGIEN,ORDDATE)
. . S:'RC RORXCNT=RORXCNT+1
. . S:RC=1 RC=0
. ;---
. D FREE^RORTMP(RORLST)
;
;===
D FREE^RORTMP(RORTMP)
Q $S(RC<0:RC,1:RORXCNT)
;
;***** PROCESS THE MEDICATION (internal)
;
; DRUGIEN IEN of the medication in the DRUG file (#50)
;
; The ROR8DST, ROR8RXS, ROR8SET, RORTMP, and RORTS variables
; must be defined before calling this function.
;
; Return Values:
; <0 Error code
; 0 Ok
; 1 Skip this medication
; 2 Skip this and all remaining medications
;
PROCMED(ORDER,ORDFLG,DRUGIEN,ORDDATE) ;
N DRUGNAME,RC,ROR8BUF,SKIP,TMP
S RC=0
;=== Load some drug data
D ARWS^PSS50(DRUGIEN,,RORTS) K ROR8BUF
F TMP=2,20,25 S ROR8BUF(TMP)=$G(@RORTMP@(DRUGIEN,TMP))
S DRUGNAME=$G(@RORTMP@(DRUGIEN,.01))
S:DRUGNAME="" DRUGNAME="Unknown (IEN="_DRUGIEN_")"
K @RORTMP
;--- Generic Drug
S ROR8DST("RORXGEN")=ROR8BUF(20)
I $P(ROR8BUF(20),U,2)="" D S $P(ROR8DST("RORXGEN"),U,2)=TMP
. S TMP="Unknown ("_(+ROR8BUF(20))_")"
;--- VA Drug Class
S ROR8DST("RORXVCL")=""
D:ROR8BUF(2)'=""
. ;--- If the "national" drug class is the same, use its IEN
. I $P(ROR8BUF(25),U,2)=ROR8BUF(2) D Q
. . S ROR8DST("RORXVCL")=$P(ROR8BUF(25),U,1,2)
. ;--- Get the Drug Class IEN
. D IEN^PSN50P65(,ROR8BUF(2),RORTS)
. S TMP=+$G(@RORTMP@(0))
. S:TMP=1 ROR8DST("RORXVCL")=+$O(@RORTMP@(0))_U_ROR8BUF(2)
. K @RORTMP
;
;=== Check if the drug should be skipped
I ROR8RXS'="*" S SKIP=0 D Q:SKIP 1
. Q:$D(@ROR8RXS@(DRUGIEN))
. I $D(@ROR8RXS@("C"))>1 Q:$D(@ROR8RXS@("C",+ROR8DST("RORXVCL")))
. I $D(@ROR8RXS@("G"))>1 Q:$D(@ROR8RXS@("G",+ROR8DST("RORXGEN")))
. S SKIP=1
;
;--- Load additional drug data
;D:LOADEXT
;.
;
;=== Default output
I ROR8SET="" D Q 0
. S RORXCNT=RORXCNT+1
. M @ROR8DST@(RORXCNT)=^TMP("PS",$J)
. S TMP=ORDER_U_ORDFLG_U_ROR8DST("RORXGEN")
. S $P(TMP,U,5,6)=ROR8DST("RORXVCL")
. S @ROR8DST@(RORXCNT)=TMP
;=== Callback function
X ROR8SET ; (.ROR8DST,ORDER,ORDFLG,DRUGIEN_U_DRUGNAME,ORDDATE,special data for specific reports)
Q RC
;
;***** LOADS AND PRESELECTS PHARMACY ORDERS
;
; PTIEN IEN of the patient (DFN)
;
; FLAGS Flags to control processing
;
; STDT Start date (FileMan)
; ENDT End date (FileMan)
;
; ROR8LST Closed root for the list of preselected orders
;
; @ROR8LST@(
; Seq#, Flags that describe the order (I,O,P, etc.)
; 0) Content of the ^TMP("PS",$J,i,0) node
; returned by the OCL^PSOORRL (see the DBIA
; #2400 for details).
;
; Return Values:
; <0 Error code
; 0 No orders have been found
; >0 Number of orders
;
QUERY(PTIEN,FLAGS,STDT,ENDT,ROR8LST) ;
N IEN,IRX,ORDER,RXCNT,TMP,TYPE
K ^TMP("PS",$J),@ROR8LST
;
;--- Prepare the flags
I FLAGS["I" D S TYPE("U;I")="I"
. S:FLAGS["P" TYPE("P;I")="IP"
. S:FLAGS["V" TYPE("V;I")="IV"
I FLAGS["O" D S TYPE("R;O")="O"
. S:FLAGS["P" TYPE("P;O")="OP"
;
;--- Load the list of pharmacy orders
D OCL^PSOORRL(PTIEN,STDT,ENDT)
Q:$D(^TMP("PS",$J))<10 0
;
;--- Preselect the orders
S (IRX,RXCNT)=0
F S IRX=$O(^TMP("PS",$J,IRX)) Q:'IRX D
. S ORDER=$P($G(^TMP("PS",$J,IRX,0)),U) Q:ORDER'>0
. ;--- Check the type of order
. S TMP=$L(ORDER),TYPE=$E(ORDER,TMP-2,TMP)
. S TYPE=$G(TYPE(TYPE)) Q:TYPE=""
. ;--- Double-check the dates
. I TYPE["I" D Q:(TMP<STDT)!(TMP'<ENDT)
. . S TMP=+$P($G(^TMP("PS",$J,IRX,0)),U,15)
. I TYPE["O" D Q:TMP<STDT
. . S TMP=+$P($G(^TMP("PS",$J,IRX,0)),U,10)
. ;--- Select the order
. S RXCNT=RXCNT+1,@ROR8LST@(RXCNT)=TYPE
. S @ROR8LST@(RXCNT,0)=^TMP("PS",$J,IRX,0)
;
;--- Cleanup
K ^TMP("PS",$J)
Q RXCNT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORUTL15 9952 printed Sep 23, 2025@19:20:06 Page 2
RORUTL15 ;HCIOFO/BH,SG - PHARMACY DATA SEARCH (TOOLS) ; 04 Apr 2016 4:57 PM
+1 ;;1.5;CLINICAL CASE REGISTRIES;**13,26,28**;Feb 17, 2006;Build 66
+2 ;
+3 ; This routine uses the following IAs:
+4 ;
+5 ; #2400 OCL^PSOORRL and OEL^PSOORRL (controlled)
+6 ; #4533 ARWS^PSS50 (supported)
+7 ; #4543 IEN^PSN50P65 (supported)
+8 ; #4549 ZERO^PSS52P6 (supported)
+9 ; #4826 PSS436^PSS55 (supported)
+10 ; #10104 UP^XLFSTR (supported)
+11 ;
+12 ;******************************************************************************
+13 ;******************************************************************************
+14 ; --- ROUTINE MODIFICATION LOG ---
+15 ;
+16 ;PKG/PATCH DATE DEVELOPER MODIFICATION
+17 ;----------- ---------- ----------- ----------------------------------------
+18 ;ROR*1.5*13 DEC 2010 A SAUNDERS Patient Med History Report: retrieve
+19 ; #refills remaining and add to the
+20 ; 'callback' function call
+21 ; NOTE: Patch 11 became patch 13.
+22 ; Any references to patch 11 in the code
+23 ; below is referring to path 13.
+24 ;
+25 ;ROR*1.5*26 JUN 2015 T KOPP Callback function for SVR screening
+26 ; does not require the # of refills as a
+27 ; parameter for the Patient Med History
+28 ; Report, so a check is made for callback
+29 ; entry point RXOCB to prevent adding it.
+30 ;
+31 ;ROR*1.5*28 APR 2016 T KOPP Check for DAA drug/in house param
+32 ;******************************************************************************
+33 ;******************************************************************************
+34 QUIT
+35 ;
+36 ;***** DOUBLE-CHECKS THE OUTPATIENT RX (ORDER, REFILLS AND PARTIALS)
+37 ;
+38 ; STDT Start Date (FileMan)
+39 ; ENDT End Date (FileMan)
+40 ;
+41 ; [.NREF] Number of refills is returned via this parameter
+42 ;
+43 ; [.NPAR] Nubmer of partials is returned via this parameter
+44 ;
+45 ; The ^TMP("PS",$J) node must be populated by the OEL^PSOORRL
+46 ; before calling this function.
+47 ;
+48 ; Return Values:
+49 ; 0 Ok
+50 ; 1 Skip the order
+51 ;
DTCHECK(STDT,ENDT,NREF,NPAR) ;
+1 NEW IRP,RXDT,SKIP
+2 SET RXDT=+$PIECE($GET(^TMP("PS",$JOB,"RXN",0)),U,6)
SET (NREF,NPAR)=0
+3 SET SKIP=(RXDT<STDT)!(RXDT'<ENDT)
+4 ;--- Refills
+5 SET IRP=0
+6 FOR
SET IRP=$ORDER(^TMP("PS",$JOB,"REF",IRP))
if IRP'>0
QUIT
Begin DoDot:1
+7 SET RXDT=+$PIECE($GET(^TMP("PS",$JOB,"REF",IRP,0)),U)
+8 IF RXDT'<STDT
IF RXDT<ENDT
SET SKIP=0
SET NREF=NREF+1
QUIT
+9 KILL ^TMP("PS",$JOB,"REF",IRP)
End DoDot:1
+10 ;--- Partials
+11 SET IRP=0
+12 FOR
SET IRP=$ORDER(^TMP("PS",$JOB,"PAR",IRP))
if IRP'>0
QUIT
Begin DoDot:1
+13 SET RXDT=+$PIECE($GET(^TMP("PS",$JOB,"PAR",IRP,0)),U)
+14 IF RXDT'<STDT
IF RXDT<ENDT
SET SKIP=0
SET NPAR=NPAR+1
QUIT
+15 KILL ^TMP("PS",$JOB,"PAR",IRP)
End DoDot:1
+16 ;---
+17 QUIT SKIP
+18 ;
+19 ;***** PROCESSES THE LIST OF PRESELECTED PHARMACY ORDERS
+20 ;
+21 ; PTIEN IEN of the patient (DFN)
+22 ;
+23 ; RORFLAGS Flags to control processing
+24 ;
+25 ; ROR8LST Closed root of the list of preselected orders
+26 ;
+27 ; Return Values:
+28 ; <0 Error code
+29 ; 0 No orders have been found
+30 ; >0 Number of orders
+31 ;
PROCESS(PTIEN,RORFLAGS,ROR8LST) ;
+1 NEW DRUGIEN,IRX,IVM,LOADEXT,ORDDATE,ORDER,ORDIEN,ORDFLG,RC,ROR8SET,RORLST,RORTMP,RORTS,RORXCNT,TMP,NUMREF
+2 SET LOADEXT=(RORFLAGS["E")
+3 SET (RC,RORXCNT)=0
+4 SET RORTMP=$$ALLOC^RORTMP(.RORTS)
+5 ;
+6 ;=== Determine the storage method (default or callback)
+7 IF $GET(ROR8DST("RORCB"))?2"$"1.8UN1"^"1.8UN
Begin DoDot:1
+8 ;standard callback setup
+9 SET ROR8SET="S RC="_ROR8DST("RORCB")_"(.ROR8DST,ORDER"
+10 SET ROR8SET=ROR8SET_",ORDFLG,DRUGIEN_U_DRUGNAME,ORDDATE)"
+11 ;Patch 11/13: Variable 'RORX011' is set in routine RORX011 for the
+12 ;Patient Medications History report. If set, add # refills
+13 ;remaining (NUMREF) to the callback parameter list.
+14 IF $GET(RORX011)
IF $GET(ROR8DST("RORCB"))'["RXOCB"
SET ROR8SET=$EXTRACT(ROR8SET,1,$LENGTH(ROR8SET)-1)_",$G(NUMREF))"
+15 ;---
+16 SET ROR8DST("RORDFN")=PTIEN
+17 SET ROR8DST("ROREDT")=ROREDT
+18 SET ROR8DST("RORFLAGS")=RORFLAGS
+19 SET ROR8DST("RORSDT")=RORSDT
End DoDot:1
+20 IF '$TEST
SET ROR8SET=""
KILL @ROR8DST
+21 ;
+22 ;=== Process the list of preselected orders
+23 SET (IRX,RC)=0
+24 FOR
SET IRX=$ORDER(@ROR8LST@(IRX))
if 'IRX
QUIT
Begin DoDot:1
+25 NEW REMARK,CHOICE
+26 SET ORDFLG=$PIECE(@ROR8LST@(IRX),U)
+27 SET TMP=@ROR8LST@(IRX,0)
+28 SET ORDER=$PIECE(TMP,U)
SET ORDDATE=$PIECE(TMP,U,15)
+29 ;Patch 11/13: get #refills remaining for Patient Medication History report:
+30 IF $GET(RORX011)
SET NUMREF=$PIECE(TMP,U,5)
+31 ;--- Get the order details
+32 KILL ^TMP("PS",$JOB)
+33 DO OEL^PSOORRL(PTIEN,ORDER)
+34 if $DATA(^TMP("PS",$JOB))<10
QUIT
+35 ; Check order remark for "CHOICE"
+36 IF RORFLAGS["C"!(RORFLAGS["H")
Begin DoDot:2
+37 SET REMARK=$$UP^XLFSTR($PIECE($GET(^TMP("PS",$JOB,"RXN",0)),U,4))
+38 ; true if DAA drug, false if in house
SET CHOICE=(REMARK["CHOICE")
End DoDot:2
if $SELECT(RORFLAGS["C"
QUIT
+39 ;=== Inpatient and Outpatient Medications
+40 IF ORDFLG'["V"
Begin DoDot:2
+41 ;--- Double-check the dates for outpatient orders
+42 IF ORDFLG["O"
if $$DTCHECK(RORSDT,ROREDT)
QUIT
+43 ;--- Get the drug IEN in the DRUG file (#50)
+44 SET TMP=$GET(^TMP("PS",$JOB,"DD",1,0))
SET DRUGIEN=+$PIECE(TMP,U,3)
+45 IF DRUGIEN'>0
SET DRUGIEN=+$PIECE(TMP,U)
if DRUGIEN'>0
QUIT
+46 ;--- Process the order
+47 SET RC=$$PROCMED(ORDER,ORDFLG,DRUGIEN,ORDDATE)
+48 if 'RC
SET RORXCNT=RORXCNT+1
+49 if RC=1
SET RC=0
End DoDot:2
QUIT
+50 ;=== IV Medications
+51 SET RORLST=$$ALLOC^RORTMP(.TMP)
SET ORDIEN=+ORDER
+52 Begin DoDot:2
+53 ; Workaround for the bug in the API
NEW IEN,ORDER
+54 DO PSS436^PSS55(PTIEN,ORDIEN,TMP)
End DoDot:2
+55 IF $GET(@RORLST@(0))'>0
DO FREE^RORTMP(RORLST)
QUIT
+56 ;--- Process the additives
+57 SET IVM=0
+58 FOR
SET IVM=$ORDER(@RORLST@(ORDIEN,"ADD",IVM))
if IVM'>0
QUIT
Begin DoDot:2
+59 ;--- IEN in the IV ADDITIVES file (#52.6)
+60 SET DRUGIEN=+$PIECE($GET(@RORLST@(ORDIEN,"ADD",IVM,.01)),U)
+61 if DRUGIEN'>0
QUIT
+62 ;--- IEN in the DRUG file (#50)
+63 DO ZERO^PSS52P6(DRUGIEN,,,RORTS)
+64 if $GET(@RORTMP@(0))'>0
QUIT
+65 SET DRUGIEN=+$PIECE($GET(@RORTMP@(DRUGIEN,1)),U)
+66 if DRUGIEN'>0
QUIT
+67 ;--- Process the medication
+68 SET RC=$$PROCMED(ORDER,ORDFLG,DRUGIEN,ORDDATE)
+69 if 'RC
SET RORXCNT=RORXCNT+1
+70 if RC=1
SET RC=0
End DoDot:2
if RC
QUIT
+71 ;---
+72 DO FREE^RORTMP(RORLST)
End DoDot:1
if RC
QUIT
+73 ;
+74 ;===
+75 DO FREE^RORTMP(RORTMP)
+76 QUIT $SELECT(RC<0:RC,1:RORXCNT)
+77 ;
+78 ;***** PROCESS THE MEDICATION (internal)
+79 ;
+80 ; DRUGIEN IEN of the medication in the DRUG file (#50)
+81 ;
+82 ; The ROR8DST, ROR8RXS, ROR8SET, RORTMP, and RORTS variables
+83 ; must be defined before calling this function.
+84 ;
+85 ; Return Values:
+86 ; <0 Error code
+87 ; 0 Ok
+88 ; 1 Skip this medication
+89 ; 2 Skip this and all remaining medications
+90 ;
PROCMED(ORDER,ORDFLG,DRUGIEN,ORDDATE) ;
+1 NEW DRUGNAME,RC,ROR8BUF,SKIP,TMP
+2 SET RC=0
+3 ;=== Load some drug data
+4 DO ARWS^PSS50(DRUGIEN,,RORTS)
KILL ROR8BUF
+5 FOR TMP=2,20,25
SET ROR8BUF(TMP)=$GET(@RORTMP@(DRUGIEN,TMP))
+6 SET DRUGNAME=$GET(@RORTMP@(DRUGIEN,.01))
+7 if DRUGNAME=""
SET DRUGNAME="Unknown (IEN="_DRUGIEN_")"
+8 KILL @RORTMP
+9 ;--- Generic Drug
+10 SET ROR8DST("RORXGEN")=ROR8BUF(20)
+11 IF $PIECE(ROR8BUF(20),U,2)=""
Begin DoDot:1
+12 SET TMP="Unknown ("_(+ROR8BUF(20))_")"
End DoDot:1
SET $PIECE(ROR8DST("RORXGEN"),U,2)=TMP
+13 ;--- VA Drug Class
+14 SET ROR8DST("RORXVCL")=""
+15 if ROR8BUF(2)'=""
Begin DoDot:1
+16 ;--- If the "national" drug class is the same, use its IEN
+17 IF $PIECE(ROR8BUF(25),U,2)=ROR8BUF(2)
Begin DoDot:2
+18 SET ROR8DST("RORXVCL")=$PIECE(ROR8BUF(25),U,1,2)
End DoDot:2
QUIT
+19 ;--- Get the Drug Class IEN
+20 DO IEN^PSN50P65(,ROR8BUF(2),RORTS)
+21 SET TMP=+$GET(@RORTMP@(0))
+22 if TMP=1
SET ROR8DST("RORXVCL")=+$ORDER(@RORTMP@(0))_U_ROR8BUF(2)
+23 KILL @RORTMP
End DoDot:1
+24 ;
+25 ;=== Check if the drug should be skipped
+26 IF ROR8RXS'="*"
SET SKIP=0
Begin DoDot:1
+27 if $DATA(@ROR8RXS@(DRUGIEN))
QUIT
+28 IF $DATA(@ROR8RXS@("C"))>1
if $DATA(@ROR8RXS@("C",+ROR8DST("RORXVCL")))
QUIT
+29 IF $DATA(@ROR8RXS@("G"))>1
if $DATA(@ROR8RXS@("G",+ROR8DST("RORXGEN")))
QUIT
+30 SET SKIP=1
End DoDot:1
if SKIP
QUIT 1
+31 ;
+32 ;--- Load additional drug data
+33 ;D:LOADEXT
+34 ;.
+35 ;
+36 ;=== Default output
+37 IF ROR8SET=""
Begin DoDot:1
+38 SET RORXCNT=RORXCNT+1
+39 MERGE @ROR8DST@(RORXCNT)=^TMP("PS",$JOB)
+40 SET TMP=ORDER_U_ORDFLG_U_ROR8DST("RORXGEN")
+41 SET $PIECE(TMP,U,5,6)=ROR8DST("RORXVCL")
+42 SET @ROR8DST@(RORXCNT)=TMP
End DoDot:1
QUIT 0
+43 ;=== Callback function
+44 ; (.ROR8DST,ORDER,ORDFLG,DRUGIEN_U_DRUGNAME,ORDDATE,special data for specific reports)
XECUTE ROR8SET
+45 QUIT RC
+46 ;
+47 ;***** LOADS AND PRESELECTS PHARMACY ORDERS
+48 ;
+49 ; PTIEN IEN of the patient (DFN)
+50 ;
+51 ; FLAGS Flags to control processing
+52 ;
+53 ; STDT Start date (FileMan)
+54 ; ENDT End date (FileMan)
+55 ;
+56 ; ROR8LST Closed root for the list of preselected orders
+57 ;
+58 ; @ROR8LST@(
+59 ; Seq#, Flags that describe the order (I,O,P, etc.)
+60 ; 0) Content of the ^TMP("PS",$J,i,0) node
+61 ; returned by the OCL^PSOORRL (see the DBIA
+62 ; #2400 for details).
+63 ;
+64 ; Return Values:
+65 ; <0 Error code
+66 ; 0 No orders have been found
+67 ; >0 Number of orders
+68 ;
QUERY(PTIEN,FLAGS,STDT,ENDT,ROR8LST) ;
+1 NEW IEN,IRX,ORDER,RXCNT,TMP,TYPE
+2 KILL ^TMP("PS",$JOB),@ROR8LST
+3 ;
+4 ;--- Prepare the flags
+5 IF FLAGS["I"
Begin DoDot:1
+6 if FLAGS["P"
SET TYPE("P;I")="IP"
+7 if FLAGS["V"
SET TYPE("V;I")="IV"
End DoDot:1
SET TYPE("U;I")="I"
+8 IF FLAGS["O"
Begin DoDot:1
+9 if FLAGS["P"
SET TYPE("P;O")="OP"
End DoDot:1
SET TYPE("R;O")="O"
+10 ;
+11 ;--- Load the list of pharmacy orders
+12 DO OCL^PSOORRL(PTIEN,STDT,ENDT)
+13 if $DATA(^TMP("PS",$JOB))<10
QUIT 0
+14 ;
+15 ;--- Preselect the orders
+16 SET (IRX,RXCNT)=0
+17 FOR
SET IRX=$ORDER(^TMP("PS",$JOB,IRX))
if 'IRX
QUIT
Begin DoDot:1
+18 SET ORDER=$PIECE($GET(^TMP("PS",$JOB,IRX,0)),U)
if ORDER'>0
QUIT
+19 ;--- Check the type of order
+20 SET TMP=$LENGTH(ORDER)
SET TYPE=$EXTRACT(ORDER,TMP-2,TMP)
+21 SET TYPE=$GET(TYPE(TYPE))
if TYPE=""
QUIT
+22 ;--- Double-check the dates
+23 IF TYPE["I"
Begin DoDot:2
+24 SET TMP=+$PIECE($GET(^TMP("PS",$JOB,IRX,0)),U,15)
End DoDot:2
if (TMP<STDT)!(TMP'<ENDT)
QUIT
+25 IF TYPE["O"
Begin DoDot:2
+26 SET TMP=+$PIECE($GET(^TMP("PS",$JOB,IRX,0)),U,10)
End DoDot:2
if TMP<STDT
QUIT
+27 ;--- Select the order
+28 SET RXCNT=RXCNT+1
SET @ROR8LST@(RXCNT)=TYPE
+29 SET @ROR8LST@(RXCNT,0)=^TMP("PS",$JOB,IRX,0)
End DoDot:1
+30 ;
+31 ;--- Cleanup
+32 KILL ^TMP("PS",$JOB)
+33 QUIT RXCNT
