- 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 Jan 18, 2025@02:44:14 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 ;