- 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 Jan 18, 2025@02:45:20 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