PSOPXRM1 ;BHAM ISC/MR - Returns Patient's Prescription info ;10/16/09 15:07
;;7.0;OUTPATIENT PHARMACY;**118,344,441**;DEC 1997;Build 208
;External reference to ^PS(55 supported by DBIA 2228
;External reference to ^PS(50.7 supported by DBIA 2223
;External reference to ^PS(50.606 supported by DBIA 2174
;External reference to ^PSDRUG( supported by DBIA 221
;
NVA(DAS,DATA) ;Return data on non-VA meds.
N EM,IND1,IND2,IND3,IND4,TEMP,TEMP1
S IND1=$P(DAS,";",1),IND2=$P(DAS,";",2),IND3=$P(DAS,";",3),IND4=$P(DAS,";",4)
S TEMP=^PS(55,IND1,IND2,IND3,IND4)
S TEMP1=^PS(50.7,$P(TEMP,U,1),0)
S DATA("ORDERABLE ITEM")=$P(TEMP1,U,1)
S DATA("DOSAGE FORM")=^PS(50.606,$P(TEMP1,U,2),0)
S DATA("DISPENSE DRUG")=$P(TEMP,U,2)
S DATA("DOSAGE")=$P(TEMP,U,3)
S DATA("MEDICATION ROUTE")=$P(TEMP,U,4)
S DATA("SCHEDULE")=$P(TEMP,U,5)
S TEMP1=$P(TEMP,U,6)
S DATA("STATUS")=$S(TEMP1="":"ACTIVE",1:$$EXTERNAL^DILFD(55.05,5,"",TEMP1,.EM))
S DATA("DISCONTINUED DATE")=$P(TEMP,U,7)
S DATA("ORDER NUMBER")=$P(TEMP,U,8)
S DATA("START DATE")=$P(TEMP,U,9)
S DATA("DOCUMENTED DATE")=$P(TEMP,U,10)
S DATA("DOCUMENTED BY")=$P(TEMP,U,11)
S DATA("CLINIC")=$P(TEMP,U,12)
S DATA("INDICATION")=$P($G(^PS(55,IND1,IND2,2,2)),U)
Q
;
;====================================================
PSRX(DAS,RXAR) ; Returns Rx Information
; Input: DAS - String containing the ^PSRX location where the data
; is located, separated by ";" (semi-colon).
; Example: "329832;1;1;0" -> ^PSRX(329832,1,1,0)
;Output: .RXAR - Array/Global to be returned with the Rx Info (by Ref)
; Return: RXAR(Field Name)=Internal Value^External
; Value (when applicable)
;
N SB1,SB2,SB3,I,DA
;
; - Retrieving ^PSRX subscripts
F I=1:1:3 S @("SB"_I)=$P(DAS,";",I)
;
; - Call appropriate sub-routine (Original, Refill or Partial)
S DA=SB1 K RXAR D @($S(SB3="":"ORIG",SB2'="P":"REFL",1:"PRTL"))
;
; - Retrieve common fields
N NODE0,RXCLIN
S NODE0=$G(^PSRX(DA,0))
S RXAR("STATUS")=+$G(^PSRX(DA,"STA"))
S RXAR("ISSUE DATE")=+$P(NODE0,U,13)
S RXAR("LAST DISPENSED DATE")=+$G(^PSRX(DA,3))
S RXCLIN=+$P(NODE0,U,5)
I RXCLIN S RXAR("CLINIC")=RXCLIN_U_$$GET1^DIQ(52,DA,5)
S RXAR("PROVIDER")=$P(NODE0,U,4)_U_$$GET1^DIQ(52,DA,4)
S RXAR("DISPENSE DRUG")=$P(NODE0,U,6)_U_$$GET1^DIQ(52,DA,6)
S RXAR("DEA SPECIAL HDLG")=$P($G(^PSDRUG(+$P(NODE0,U,6),0)),U,3)
S RXAR("INDICATION")=$P($G(^PSRX(DA,"IND")),U)
;
END Q
;
ORIG ; - Retrieve Original fields
N RX0,RX2 S RX0=$G(^PSRX(DA,0)),RX2=$G(^PSRX(DA,2))
S RXAR("DAYS SUPPLY")=$P(RX0,"^",8)
S RXAR("PHARMACIST")=$S($P(RX2,"^",3):$P(RX2,"^",3)_U_$$GET1^DIQ(52,DA,23),1:"")
S RXAR("RELEASED DATE/TIME")=$P(RX2,"^",13)
S RXAR("QTY")=+$P(RX0,U,7)
Q
;
REFL ; - Retrieve Refill fields
N RF0 S RF0=$G(^PSRX(DA,1,SB3,0))
S RXAR("DAYS SUPPLY")=$P(RF0,"^",10)
S RXAR("PHARMACIST")=$S($P(RF0,"^",5):$P(RF0,"^",5)_U_$$GET1^DIQ(52.1,SB3_","_DA,4),1:"")
S RXAR("RELEASED DATE/TIME")=$P(RF0,"^",18)
S RXAR("QTY")=+$P(RF0,U,4)
Q
;
PRTL ; - Retrieve Partial fields
N PT0 S PT0=$G(^PSRX(DA,"P",SB3,0))
S RXAR("DAYS SUPPLY")=$P(PT0,"^",10)
S RXAR("PHARMACIST")=$S($P(PT0,"^",5):$P(PT0,"^",5)_U_$$GET1^DIQ(52.2,SB3_","_DA,.05),1:"")
S RXAR("RELEASED DATE/TIME")=$P(PT0,"^",19)
S RXAR("QTY")=+$P(PT0,U,4)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOPXRM1 3387 printed Sep 23, 2025@20:09:37 Page 2
PSOPXRM1 ;BHAM ISC/MR - Returns Patient's Prescription info ;10/16/09 15:07
+1 ;;7.0;OUTPATIENT PHARMACY;**118,344,441**;DEC 1997;Build 208
+2 ;External reference to ^PS(55 supported by DBIA 2228
+3 ;External reference to ^PS(50.7 supported by DBIA 2223
+4 ;External reference to ^PS(50.606 supported by DBIA 2174
+5 ;External reference to ^PSDRUG( supported by DBIA 221
+6 ;
NVA(DAS,DATA) ;Return data on non-VA meds.
+1 NEW EM,IND1,IND2,IND3,IND4,TEMP,TEMP1
+2 SET IND1=$PIECE(DAS,";",1)
SET IND2=$PIECE(DAS,";",2)
SET IND3=$PIECE(DAS,";",3)
SET IND4=$PIECE(DAS,";",4)
+3 SET TEMP=^PS(55,IND1,IND2,IND3,IND4)
+4 SET TEMP1=^PS(50.7,$PIECE(TEMP,U,1),0)
+5 SET DATA("ORDERABLE ITEM")=$PIECE(TEMP1,U,1)
+6 SET DATA("DOSAGE FORM")=^PS(50.606,$PIECE(TEMP1,U,2),0)
+7 SET DATA("DISPENSE DRUG")=$PIECE(TEMP,U,2)
+8 SET DATA("DOSAGE")=$PIECE(TEMP,U,3)
+9 SET DATA("MEDICATION ROUTE")=$PIECE(TEMP,U,4)
+10 SET DATA("SCHEDULE")=$PIECE(TEMP,U,5)
+11 SET TEMP1=$PIECE(TEMP,U,6)
+12 SET DATA("STATUS")=$SELECT(TEMP1="":"ACTIVE",1:$$EXTERNAL^DILFD(55.05,5,"",TEMP1,.EM))
+13 SET DATA("DISCONTINUED DATE")=$PIECE(TEMP,U,7)
+14 SET DATA("ORDER NUMBER")=$PIECE(TEMP,U,8)
+15 SET DATA("START DATE")=$PIECE(TEMP,U,9)
+16 SET DATA("DOCUMENTED DATE")=$PIECE(TEMP,U,10)
+17 SET DATA("DOCUMENTED BY")=$PIECE(TEMP,U,11)
+18 SET DATA("CLINIC")=$PIECE(TEMP,U,12)
+19 SET DATA("INDICATION")=$PIECE($GET(^PS(55,IND1,IND2,2,2)),U)
+20 QUIT
+21 ;
+22 ;====================================================
PSRX(DAS,RXAR) ; Returns Rx Information
+1 ; Input: DAS - String containing the ^PSRX location where the data
+2 ; is located, separated by ";" (semi-colon).
+3 ; Example: "329832;1;1;0" -> ^PSRX(329832,1,1,0)
+4 ;Output: .RXAR - Array/Global to be returned with the Rx Info (by Ref)
+5 ; Return: RXAR(Field Name)=Internal Value^External
+6 ; Value (when applicable)
+7 ;
+8 NEW SB1,SB2,SB3,I,DA
+9 ;
+10 ; - Retrieving ^PSRX subscripts
+11 FOR I=1:1:3
SET @("SB"_I)=$PIECE(DAS,";",I)
+12 ;
+13 ; - Call appropriate sub-routine (Original, Refill or Partial)
+14 SET DA=SB1
KILL RXAR
DO @($SELECT(SB3="":"ORIG",SB2'="P":"REFL",1:"PRTL"))
+15 ;
+16 ; - Retrieve common fields
+17 NEW NODE0,RXCLIN
+18 SET NODE0=$GET(^PSRX(DA,0))
+19 SET RXAR("STATUS")=+$GET(^PSRX(DA,"STA"))
+20 SET RXAR("ISSUE DATE")=+$PIECE(NODE0,U,13)
+21 SET RXAR("LAST DISPENSED DATE")=+$GET(^PSRX(DA,3))
+22 SET RXCLIN=+$PIECE(NODE0,U,5)
+23 IF RXCLIN
SET RXAR("CLINIC")=RXCLIN_U_$$GET1^DIQ(52,DA,5)
+24 SET RXAR("PROVIDER")=$PIECE(NODE0,U,4)_U_$$GET1^DIQ(52,DA,4)
+25 SET RXAR("DISPENSE DRUG")=$PIECE(NODE0,U,6)_U_$$GET1^DIQ(52,DA,6)
+26 SET RXAR("DEA SPECIAL HDLG")=$PIECE($GET(^PSDRUG(+$PIECE(NODE0,U,6),0)),U,3)
+27 SET RXAR("INDICATION")=$PIECE($GET(^PSRX(DA,"IND")),U)
+28 ;
END QUIT
+1 ;
ORIG ; - Retrieve Original fields
+1 NEW RX0,RX2
SET RX0=$GET(^PSRX(DA,0))
SET RX2=$GET(^PSRX(DA,2))
+2 SET RXAR("DAYS SUPPLY")=$PIECE(RX0,"^",8)
+3 SET RXAR("PHARMACIST")=$SELECT($PIECE(RX2,"^",3):$PIECE(RX2,"^",3)_U_$$GET1^DIQ(52,DA,23),1:"")
+4 SET RXAR("RELEASED DATE/TIME")=$PIECE(RX2,"^",13)
+5 SET RXAR("QTY")=+$PIECE(RX0,U,7)
+6 QUIT
+7 ;
REFL ; - Retrieve Refill fields
+1 NEW RF0
SET RF0=$GET(^PSRX(DA,1,SB3,0))
+2 SET RXAR("DAYS SUPPLY")=$PIECE(RF0,"^",10)
+3 SET RXAR("PHARMACIST")=$SELECT($PIECE(RF0,"^",5):$PIECE(RF0,"^",5)_U_$$GET1^DIQ(52.1,SB3_","_DA,4),1:"")
+4 SET RXAR("RELEASED DATE/TIME")=$PIECE(RF0,"^",18)
+5 SET RXAR("QTY")=+$PIECE(RF0,U,4)
+6 QUIT
+7 ;
PRTL ; - Retrieve Partial fields
+1 NEW PT0
SET PT0=$GET(^PSRX(DA,"P",SB3,0))
+2 SET RXAR("DAYS SUPPLY")=$PIECE(PT0,"^",10)
+3 SET RXAR("PHARMACIST")=$SELECT($PIECE(PT0,"^",5):$PIECE(PT0,"^",5)_U_$$GET1^DIQ(52.2,SB3_","_DA,.05),1:"")
+4 SET RXAR("RELEASED DATE/TIME")=$PIECE(PT0,"^",19)
+5 SET RXAR("QTY")=+$PIECE(PT0,U,4)
+6 QUIT
