RORRP017 ;HIOFO/SG,VC - RPC: DRUGS AND CLASSES ;4/17/09 10:45am
;;1.5;CLINICAL CASE REGISTRIES;**8**;Feb 17, 2006;Build 8
;
; This routine uses the following IAs:
;
; #4533 ZERO^PSS50, NDF^PSS50, DATA^PSS50 (supported)
; #4540 ZERO^PSN50P6 (supported)
; #4543 C^PSN50P65, IEN^PSN50P65 (supported)
;
; This routine was modified March 2009 to include Registry Drugs
; RPC call is ROR LIST REGISTRY DRUGS into tag RORGEN
;
Q
;
;***** RETURNS THE LIST OF DRUGS (DISPENSED OR GENERIC)
; RPC: [ROR LIST DRUGS]
;
; .RESULTS Reference to a local variable where the results
; are returned to.
;
; [PART] The partial match restriction.
;
; [FLAGS] Flags that control the execution (can be combined):
; G Retrive generic drugs (from file #50.6).
; Otherwise, list of dispensed drugs (from
; file #50) is retrieved.
;
; [NUMBER] Deprecated
; [FROM] Deprecated
;
; 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, number of drugs is returned in the
; @RESULTS@(0) and the subsequent nodes of the global array
; contain the drugs.
;
; @RESULTS@(0) Number of drugs
;
; @RESULTS@(i) Drug
; ^01: Drug IEN
; ^02: Drug Name
; ^03: VA Drug Class (only for dispensed)
;
DRUGLIST(RESULTS,PART,FLAGS,NUMBER,FROM) ;
N BUF,CNT,GENERIC,IEN,LP,NAME,NODE,RC,RORERRDL,TMP
D CLEAR^RORERR("DRUGLIST^RORRP017",1)
K RESULTS S RESULTS=$$ALLOC^RORTMP()
;--- Check the parameters
S FLAGS=$G(FLAGS) S:$G(PART)="" PART="??"
S GENERIC=(FLAGS["G")
;--- Get the list of drugs
S NODE=$$ALLOC^RORTMP(.TMP)
I GENERIC D
. D ZERO^PSN50P6(,PART,,,TMP) ; Generic
E D ZERO^PSS50(,PART,,,,TMP) ; Dispensed
;--- Copy the data to the destination array
S:PART="??" PART="" S LP=$L(PART)
S NAME="",CNT=0
F S NAME=$O(@NODE@("B",NAME)) Q:NAME="" D
. S IEN=""
. F S IEN=$O(@NODE@("B",NAME,IEN)) Q:IEN="" D
. . S TMP=$G(@NODE@(IEN,.01)) Q:TMP=""
. . Q:$E(TMP,1,LP)'=PART ; Exclude mnemonics
. . S BUF=IEN_U_TMP S:'GENERIC $P(BUF,U,3)=$G(@NODE@(IEN,2))
. . S CNT=CNT+1,@RESULTS@(CNT)=BUF
;--- Success
S @RESULTS@(0)=CNT
D FREE^RORTMP(NODE)
Q
;
;***** RETURNS THE LIST OF VA DRUG CLASSES
; RPC: [ROR LIST VA DRUG CLASSES]
;
; .RESULTS Reference to a local variable where the results
; are returned to.
;
; [PARENT] Reserved
;
; [PART] The partial match restriction.
;
; [FLAGS] Flags that control the execution (can be combined):
; N Search classes by their names
; (by default, the search is performed by codes)
;
; [NUMBER] Deprecated
; [FROM] Deprecated
;
; 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, number of drug classes is returned in the
; @RESULTS@(0) and the subsequent nodes of the global array
; contain the classes.
;
; @RESULTS@(0) Number of classes
;
; @RESULTS@(i) Drug Class
; ^01: IEN
; ^02: Classification
; ^03: Code
;
VACLSLST(RESULTS,PARENT,PART,FLAGS,NUMBER,FROM) ;
N CNT,IEN,LP,NODE,RC,RORERRDL,SUBS,TMP,VAL,XREF
D CLEAR^RORERR("VACLSLST^RORRP017",1)
K RESULTS S RESULTS=$$ALLOC^RORTMP()
;--- Check the parameters
S FLAGS=$G(FLAGS) S:$G(PART)="" PART="??"
;--- Get the list of codes
S NODE=$$ALLOC^RORTMP(.TMP)
I FLAGS["N" D S XREF="C",SUBS=1
. D C^PSN50P65(,PART,TMP)
E D S XREF="B",SUBS=.01
. D IEN^PSN50P65(,PART,TMP)
;--- Copy the data to the destination array
S:PART="??" PART="" S LP=$L(PART)
S VAL="",CNT=0
F S VAL=$O(@NODE@(XREF,VAL)) Q:VAL="" D
. S IEN=""
. F S IEN=$O(@NODE@(XREF,VAL,IEN)) Q:IEN="" D
. . S TMP=$G(@NODE@(IEN,SUBS))
. . Q:$E(TMP,1,LP)'=PART ; Exclude mnemonics
. . S CNT=CNT+1
. . S @RESULTS@(CNT)=IEN_U_$G(@NODE@(IEN,1))_U_$G(@NODE@(IEN,.01))
;--- Success
S @RESULTS@(0)=CNT
D FREE^RORTMP(NODE)
Q
;
;***** RETURNS THE LIST OF REGISTRY DRUGS
; RPC: [ROR LIST REGISTRY DRUGS]
; .RESULTS Reference to a local variable where the results
; are return to
; PART The partial match value passed in from Application
; FLAGS Not used
; NUMBER Not used
; FROM Not used
;
; Information returned
; @RESULTS@(0) Number of drugs returned
; @RESULTS@(n) Drug Class
; $p1= IEN
; $p2= NAME OF DRUG
;
RORGEN(RESULTS,PART,FLAGS,NUMBER,FROM) ;
N BUF,CNT,GENERIC,IEN,LP,NAME,RC,RORERRDL,TMP,REGID,RRIEN
D CLEAR^RORERR("RORGEN^RORRP017",1)
K RESULTS S RESULTS=$$ALLOC^RORTMP()
S:$G(PART)="" PART="??"
S:PART="??" PART=""
S LP=$L(PART)
S NAME=PART,CNT=0
F S NAME=$O(^ROR(799.51,"B",NAME)) Q:NAME="" D
. Q:$E(NAME,1,LP)'=PART
.S IEN=""
.F S IEN=$O(^ROR(799.51,"B",NAME,IEN)) Q:IEN="" D
. . S REGID=$P($G(^ROR(799.51,IEN,0)),U,2)
. . Q:REGID'=FLAGS
. . S RRIEN=$P($G(^ROR(799.51,IEN,0)),U,4)
. . S BUF=RRIEN_U_NAME,CNT=CNT+1
. . S @RESULTS@(CNT)=BUF
S @RESULTS@(0)=CNT
Q
;
;--- Returns a list of Investigative Drugs per registry
; RPC: [ROR LIST INVESTIGATIVE DRUGS]
; .RESULTS Reference to a local variable where the results
; are returned to
; PART The partial match value passed in from the application
; FLAGS Indicator of registry HEPC=1, HIV=2
; NUMBER Not used
; FROM Not used
RORINV(RESULTS,PART,FLAGS,NUMBER,FROM) ;
N BUF,CNT,IEN,LP,NAME,NODE,RC,RORERRDL,TMP,TMP2,INVES,CLAS,SUBS,PNTR
N RORREG,XREF,VAL
D CLEAR^RORERR("RORINV^RORRP017",1)
K RESULTS
S RESULTS=$$ALLOC^RORTMP()
S NODE=$$ALLOC^RORTMP(.TMP)
S SUBS=$$ALLOC^RORTMP(.TMP2)
S FLAGS=$G(FLAGS)
I FLAGS=1 S RORREG="IN140"
I FLAGS=2 S RORREG="IN150"
S:$G(PART)="" PART="??"
S:PART="??" PART=""
S LP=$L(PART)
;D B^PSS50(PART,,,,TMP)
D NDF^PSS50(,PART,,,,TMP)
S XREF="B"
S VAL="",CNT=0
F S VAL=$O(@NODE@(XREF,VAL)) Q:VAL="" D
. S IEN=""
. F S IEN=$O(@NODE@(XREF,VAL,IEN)) Q:IEN="" D
. . D DATA^PSS50(IEN,,,,,TMP2)
. . S CLAS=$P($G(@SUBS@(IEN,25)),U,2)
. . Q:CLAS'=RORREG
. . S PNTR=$P($G(@SUBS@(IEN,20)),U,1)
. . S CNT=CNT+1
. . S BUF=PNTR_U_$G(@SUBS@(IEN,.01))
. . S @RESULTS@(CNT)=BUF
S @RESULTS@(0)=CNT
D FREE^RORTMP(NODE)
D FREE^RORTMP(SUBS)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORRP017 6801 printed Dec 13, 2024@01:43 Page 2
RORRP017 ;HIOFO/SG,VC - RPC: DRUGS AND CLASSES ;4/17/09 10:45am
+1 ;;1.5;CLINICAL CASE REGISTRIES;**8**;Feb 17, 2006;Build 8
+2 ;
+3 ; This routine uses the following IAs:
+4 ;
+5 ; #4533 ZERO^PSS50, NDF^PSS50, DATA^PSS50 (supported)
+6 ; #4540 ZERO^PSN50P6 (supported)
+7 ; #4543 C^PSN50P65, IEN^PSN50P65 (supported)
+8 ;
+9 ; This routine was modified March 2009 to include Registry Drugs
+10 ; RPC call is ROR LIST REGISTRY DRUGS into tag RORGEN
+11 ;
+12 QUIT
+13 ;
+14 ;***** RETURNS THE LIST OF DRUGS (DISPENSED OR GENERIC)
+15 ; RPC: [ROR LIST DRUGS]
+16 ;
+17 ; .RESULTS Reference to a local variable where the results
+18 ; are returned to.
+19 ;
+20 ; [PART] The partial match restriction.
+21 ;
+22 ; [FLAGS] Flags that control the execution (can be combined):
+23 ; G Retrive generic drugs (from file #50.6).
+24 ; Otherwise, list of dispensed drugs (from
+25 ; file #50) is retrieved.
+26 ;
+27 ; [NUMBER] Deprecated
+28 ; [FROM] Deprecated
+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, number of drugs is returned in the
+37 ; @RESULTS@(0) and the subsequent nodes of the global array
+38 ; contain the drugs.
+39 ;
+40 ; @RESULTS@(0) Number of drugs
+41 ;
+42 ; @RESULTS@(i) Drug
+43 ; ^01: Drug IEN
+44 ; ^02: Drug Name
+45 ; ^03: VA Drug Class (only for dispensed)
+46 ;
DRUGLIST(RESULTS,PART,FLAGS,NUMBER,FROM) ;
+1 NEW BUF,CNT,GENERIC,IEN,LP,NAME,NODE,RC,RORERRDL,TMP
+2 DO CLEAR^RORERR("DRUGLIST^RORRP017",1)
+3 KILL RESULTS
SET RESULTS=$$ALLOC^RORTMP()
+4 ;--- Check the parameters
+5 SET FLAGS=$GET(FLAGS)
if $GET(PART)=""
SET PART="??"
+6 SET GENERIC=(FLAGS["G")
+7 ;--- Get the list of drugs
+8 SET NODE=$$ALLOC^RORTMP(.TMP)
+9 IF GENERIC
Begin DoDot:1
+10 ; Generic
DO ZERO^PSN50P6(,PART,,,TMP)
End DoDot:1
+11 ; Dispensed
IF '$TEST
DO ZERO^PSS50(,PART,,,,TMP)
+12 ;--- Copy the data to the destination array
+13 if PART="??"
SET PART=""
SET LP=$LENGTH(PART)
+14 SET NAME=""
SET CNT=0
+15 FOR
SET NAME=$ORDER(@NODE@("B",NAME))
if NAME=""
QUIT
Begin DoDot:1
+16 SET IEN=""
+17 FOR
SET IEN=$ORDER(@NODE@("B",NAME,IEN))
if IEN=""
QUIT
Begin DoDot:2
+18 SET TMP=$GET(@NODE@(IEN,.01))
if TMP=""
QUIT
+19 ; Exclude mnemonics
if $EXTRACT(TMP,1,LP)'=PART
QUIT
+20 SET BUF=IEN_U_TMP
if 'GENERIC
SET $PIECE(BUF,U,3)=$GET(@NODE@(IEN,2))
+21 SET CNT=CNT+1
SET @RESULTS@(CNT)=BUF
End DoDot:2
End DoDot:1
+22 ;--- Success
+23 SET @RESULTS@(0)=CNT
+24 DO FREE^RORTMP(NODE)
+25 QUIT
+26 ;
+27 ;***** RETURNS THE LIST OF VA DRUG CLASSES
+28 ; RPC: [ROR LIST VA DRUG CLASSES]
+29 ;
+30 ; .RESULTS Reference to a local variable where the results
+31 ; are returned to.
+32 ;
+33 ; [PARENT] Reserved
+34 ;
+35 ; [PART] The partial match restriction.
+36 ;
+37 ; [FLAGS] Flags that control the execution (can be combined):
+38 ; N Search classes by their names
+39 ; (by default, the search is performed by codes)
+40 ;
+41 ; [NUMBER] Deprecated
+42 ; [FROM] Deprecated
+43 ;
+44 ; Return Values:
+45 ;
+46 ; A negative value of the first "^"-piece of the @RESULTS@(0)
+47 ; indicates an error (see the RPCSTK^RORERR procedure for more
+48 ; details).
+49 ;
+50 ; Otherwise, number of drug classes is returned in the
+51 ; @RESULTS@(0) and the subsequent nodes of the global array
+52 ; contain the classes.
+53 ;
+54 ; @RESULTS@(0) Number of classes
+55 ;
+56 ; @RESULTS@(i) Drug Class
+57 ; ^01: IEN
+58 ; ^02: Classification
+59 ; ^03: Code
+60 ;
VACLSLST(RESULTS,PARENT,PART,FLAGS,NUMBER,FROM) ;
+1 NEW CNT,IEN,LP,NODE,RC,RORERRDL,SUBS,TMP,VAL,XREF
+2 DO CLEAR^RORERR("VACLSLST^RORRP017",1)
+3 KILL RESULTS
SET RESULTS=$$ALLOC^RORTMP()
+4 ;--- Check the parameters
+5 SET FLAGS=$GET(FLAGS)
if $GET(PART)=""
SET PART="??"
+6 ;--- Get the list of codes
+7 SET NODE=$$ALLOC^RORTMP(.TMP)
+8 IF FLAGS["N"
Begin DoDot:1
+9 DO C^PSN50P65(,PART,TMP)
End DoDot:1
SET XREF="C"
SET SUBS=1
+10 IF '$TEST
Begin DoDot:1
+11 DO IEN^PSN50P65(,PART,TMP)
End DoDot:1
SET XREF="B"
SET SUBS=.01
+12 ;--- Copy the data to the destination array
+13 if PART="??"
SET PART=""
SET LP=$LENGTH(PART)
+14 SET VAL=""
SET CNT=0
+15 FOR
SET VAL=$ORDER(@NODE@(XREF,VAL))
if VAL=""
QUIT
Begin DoDot:1
+16 SET IEN=""
+17 FOR
SET IEN=$ORDER(@NODE@(XREF,VAL,IEN))
if IEN=""
QUIT
Begin DoDot:2
+18 SET TMP=$GET(@NODE@(IEN,SUBS))
+19 ; Exclude mnemonics
if $EXTRACT(TMP,1,LP)'=PART
QUIT
+20 SET CNT=CNT+1
+21 SET @RESULTS@(CNT)=IEN_U_$GET(@NODE@(IEN,1))_U_$GET(@NODE@(IEN,.01))
End DoDot:2
End DoDot:1
+22 ;--- Success
+23 SET @RESULTS@(0)=CNT
+24 DO FREE^RORTMP(NODE)
+25 QUIT
+26 ;
+27 ;***** RETURNS THE LIST OF REGISTRY DRUGS
+28 ; RPC: [ROR LIST REGISTRY DRUGS]
+29 ; .RESULTS Reference to a local variable where the results
+30 ; are return to
+31 ; PART The partial match value passed in from Application
+32 ; FLAGS Not used
+33 ; NUMBER Not used
+34 ; FROM Not used
+35 ;
+36 ; Information returned
+37 ; @RESULTS@(0) Number of drugs returned
+38 ; @RESULTS@(n) Drug Class
+39 ; $p1= IEN
+40 ; $p2= NAME OF DRUG
+41 ;
RORGEN(RESULTS,PART,FLAGS,NUMBER,FROM) ;
+1 NEW BUF,CNT,GENERIC,IEN,LP,NAME,RC,RORERRDL,TMP,REGID,RRIEN
+2 DO CLEAR^RORERR("RORGEN^RORRP017",1)
+3 KILL RESULTS
SET RESULTS=$$ALLOC^RORTMP()
+4 if $GET(PART)=""
SET PART="??"
+5 if PART="??"
SET PART=""
+6 SET LP=$LENGTH(PART)
+7 SET NAME=PART
SET CNT=0
+8 FOR
SET NAME=$ORDER(^ROR(799.51,"B",NAME))
if NAME=""
QUIT
Begin DoDot:1
+9 if $EXTRACT(NAME,1,LP)'=PART
QUIT
+10 SET IEN=""
+11 FOR
SET IEN=$ORDER(^ROR(799.51,"B",NAME,IEN))
if IEN=""
QUIT
Begin DoDot:2
+12 SET REGID=$PIECE($GET(^ROR(799.51,IEN,0)),U,2)
+13 if REGID'=FLAGS
QUIT
+14 SET RRIEN=$PIECE($GET(^ROR(799.51,IEN,0)),U,4)
+15 SET BUF=RRIEN_U_NAME
SET CNT=CNT+1
+16 SET @RESULTS@(CNT)=BUF
End DoDot:2
End DoDot:1
+17 SET @RESULTS@(0)=CNT
+18 QUIT
+19 ;
+20 ;--- Returns a list of Investigative Drugs per registry
+21 ; RPC: [ROR LIST INVESTIGATIVE DRUGS]
+22 ; .RESULTS Reference to a local variable where the results
+23 ; are returned to
+24 ; PART The partial match value passed in from the application
+25 ; FLAGS Indicator of registry HEPC=1, HIV=2
+26 ; NUMBER Not used
+27 ; FROM Not used
RORINV(RESULTS,PART,FLAGS,NUMBER,FROM) ;
+1 NEW BUF,CNT,IEN,LP,NAME,NODE,RC,RORERRDL,TMP,TMP2,INVES,CLAS,SUBS,PNTR
+2 NEW RORREG,XREF,VAL
+3 DO CLEAR^RORERR("RORINV^RORRP017",1)
+4 KILL RESULTS
+5 SET RESULTS=$$ALLOC^RORTMP()
+6 SET NODE=$$ALLOC^RORTMP(.TMP)
+7 SET SUBS=$$ALLOC^RORTMP(.TMP2)
+8 SET FLAGS=$GET(FLAGS)
+9 IF FLAGS=1
SET RORREG="IN140"
+10 IF FLAGS=2
SET RORREG="IN150"
+11 if $GET(PART)=""
SET PART="??"
+12 if PART="??"
SET PART=""
+13 SET LP=$LENGTH(PART)
+14 ;D B^PSS50(PART,,,,TMP)
+15 DO NDF^PSS50(,PART,,,,TMP)
+16 SET XREF="B"
+17 SET VAL=""
SET CNT=0
+18 FOR
SET VAL=$ORDER(@NODE@(XREF,VAL))
if VAL=""
QUIT
Begin DoDot:1
+19 SET IEN=""
+20 FOR
SET IEN=$ORDER(@NODE@(XREF,VAL,IEN))
if IEN=""
QUIT
Begin DoDot:2
+21 DO DATA^PSS50(IEN,,,,,TMP2)
+22 SET CLAS=$PIECE($GET(@SUBS@(IEN,25)),U,2)
+23 if CLAS'=RORREG
QUIT
+24 SET PNTR=$PIECE($GET(@SUBS@(IEN,20)),U,1)
+25 SET CNT=CNT+1
+26 SET BUF=PNTR_U_$GET(@SUBS@(IEN,.01))
+27 SET @RESULTS@(CNT)=BUF
End DoDot:2
End DoDot:1
+28 SET @RESULTS@(0)=CNT
+29 DO FREE^RORTMP(NODE)
+30 DO FREE^RORTMP(SUBS)
+31 QUIT
+32 ;
