PSO52AP1 ;BHM/SAB - Encapsulation II API to return Rx data ;04/07/05 10:30 am
;;7.0;OUTPATIENT PHARMACY;**213,245,276**;DEC 1997;Build 15
;
;Reference to ^PS(55 supported by DBIA 2228
;Reference to ^PSDRUG supported by DBIA 221
;
;Rx profile called from PROF^PSO52API
;DFN: Patient's IEN
;LIST: Subscript name used in ^TMP global [REQUIRED]
;SDATE: Starting Expiration Date [optional]
;EDATE: Ending Expiration Date [optional]
;
Q:$G(LIST)=""
N DA,DR,PST,DIC,DIQ,DATE,IEN K ^TMP($J,LIST)
Q:'$G(DFN)
I '$O(^PS(55,DFN,"P",0)),$O(^PS(55,DFN,"ARC",0)) S ^TMP($J,LIST,DFN,"ARC",0)="PATIENT HAS ARCHIVED PRESCRIPTIONS"
I $G(SDATE) S DATE=SDATE-1 D G EX
.I $G(EDATE) F S DATE=$O(^PS(55,DFN,"P","A",DATE)) Q:'DATE!(DATE>EDATE) F IEN=0:0 S IEN=$O(^PS(55,DFN,"P","A",DATE,IEN)) Q:'IEN D ND
.I '$G(EDATE) F S DATE=$O(^PS(55,DFN,"P","A",DATE)) Q:'DATE F IEN=0:0 S IEN=$O(^PS(55,DFN,"P","A",DATE,IEN)) Q:'IEN D ND
I $G(EDATE),'$G(SDATE) S DATE=DT-1 D G EX
.F S DATE=$O(^PS(55,DFN,"P","A",DATE)) Q:'DATE!(DATE>EDATE) F IEN=0:0 S IEN=$O(^PS(55,DFN,"P","A",DATE,IEN)) Q:'IEN D ND
S DATE=DT-1 F S DATE=$O(^PS(55,DFN,"P","A",DATE)) Q:'DATE F IEN=0:0 S IEN=$O(^PS(55,DFN,"P","A",DATE,IEN)) Q:'IEN D ND
EX I $G(DFN),$G(LIST)]"",'$O(^TMP($J,LIST,DFN,0)) S ^TMP($J,LIST,DFN,0)="-1^NO PRESCRIPTION DATA FOUND"
Q
ND ;returns data
I DFN'=$P($G(^PSRX(IEN,0)),"^",2) Q
I $G(^PSRX(IEN,0))']"" Q
Q:$P($G(^PSRX(IEN,"STA")),"^")=13
S ^TMP($J,LIST,DFN,0)=$G(^TMP($J,LIST,DFN,0))+1
I DT>$P(^PSRX(IEN,2),"^",6),$P(^PSRX(IEN,"STA"),"^")<11 D
.N PSOEXRX,PSOEXSTA,ORN,PIFN,PSUSD,PRFDT,PDA,PSDTEST,PSOVADM
.S PSOEXRX=IEN M PSOVADM=VADM D EN2^PSOMAUEX M VADM=PSOVADM K PSOEXRX,PSONM,PSONMX
K PST S DIC=52,DA=IEN,DR=".01:9;10.3;10.6;11;16;17;100"
S DIQ="PST",DIQ(0)="IE" D EN^DIQ1
S ^TMP($J,LIST,"B",PST(52,DA,.01,"E"),IEN)=""
F DR=.01,1,2,3,4,5,6,6.5,7,8,9,10.3,10.6,11,16,17,100 D
.I PST(52,DA,DR,"E")'=PST(52,DA,DR,"I") S ^TMP($J,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")_"^"_PST(52,DA,DR,"E") Q
.S ^TMP($J,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")
S $P(^TMP($J,LIST,DFN,IEN,.01),U,2)=IEN
K DA,DR,PST,DIC,DIQ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSO52AP1 2154 printed Sep 23, 2025@19:59:16 Page 2
PSO52AP1 ;BHM/SAB - Encapsulation II API to return Rx data ;04/07/05 10:30 am
+1 ;;7.0;OUTPATIENT PHARMACY;**213,245,276**;DEC 1997;Build 15
+2 ;
+3 ;Reference to ^PS(55 supported by DBIA 2228
+4 ;Reference to ^PSDRUG supported by DBIA 221
+5 ;
+6 ;Rx profile called from PROF^PSO52API
+7 ;DFN: Patient's IEN
+8 ;LIST: Subscript name used in ^TMP global [REQUIRED]
+9 ;SDATE: Starting Expiration Date [optional]
+10 ;EDATE: Ending Expiration Date [optional]
+11 ;
+12 if $GET(LIST)=""
QUIT
+13 NEW DA,DR,PST,DIC,DIQ,DATE,IEN
KILL ^TMP($JOB,LIST)
+14 if '$GET(DFN)
QUIT
+15 IF '$ORDER(^PS(55,DFN,"P",0))
IF $ORDER(^PS(55,DFN,"ARC",0))
SET ^TMP($JOB,LIST,DFN,"ARC",0)="PATIENT HAS ARCHIVED PRESCRIPTIONS"
+16 IF $GET(SDATE)
SET DATE=SDATE-1
Begin DoDot:1
+17 IF $GET(EDATE)
FOR
SET DATE=$ORDER(^PS(55,DFN,"P","A",DATE))
if 'DATE!(DATE>EDATE)
QUIT
FOR IEN=0:0
SET IEN=$ORDER(^PS(55,DFN,"P","A",DATE,IEN))
if 'IEN
QUIT
DO ND
+18 IF '$GET(EDATE)
FOR
SET DATE=$ORDER(^PS(55,DFN,"P","A",DATE))
if 'DATE
QUIT
FOR IEN=0:0
SET IEN=$ORDER(^PS(55,DFN,"P","A",DATE,IEN))
if 'IEN
QUIT
DO ND
End DoDot:1
GOTO EX
+19 IF $GET(EDATE)
IF '$GET(SDATE)
SET DATE=DT-1
Begin DoDot:1
+20 FOR
SET DATE=$ORDER(^PS(55,DFN,"P","A",DATE))
if 'DATE!(DATE>EDATE)
QUIT
FOR IEN=0:0
SET IEN=$ORDER(^PS(55,DFN,"P","A",DATE,IEN))
if 'IEN
QUIT
DO ND
End DoDot:1
GOTO EX
+21 SET DATE=DT-1
FOR
SET DATE=$ORDER(^PS(55,DFN,"P","A",DATE))
if 'DATE
QUIT
FOR IEN=0:0
SET IEN=$ORDER(^PS(55,DFN,"P","A",DATE,IEN))
if 'IEN
QUIT
DO ND
EX IF $GET(DFN)
IF $GET(LIST)]""
IF '$ORDER(^TMP($JOB,LIST,DFN,0))
SET ^TMP($JOB,LIST,DFN,0)="-1^NO PRESCRIPTION DATA FOUND"
+1 QUIT
ND ;returns data
+1 IF DFN'=$PIECE($GET(^PSRX(IEN,0)),"^",2)
QUIT
+2 IF $GET(^PSRX(IEN,0))']""
QUIT
+3 if $PIECE($GET(^PSRX(IEN,"STA")),"^")=13
QUIT
+4 SET ^TMP($JOB,LIST,DFN,0)=$GET(^TMP($JOB,LIST,DFN,0))+1
+5 IF DT>$PIECE(^PSRX(IEN,2),"^",6)
IF $PIECE(^PSRX(IEN,"STA"),"^")<11
Begin DoDot:1
+6 NEW PSOEXRX,PSOEXSTA,ORN,PIFN,PSUSD,PRFDT,PDA,PSDTEST,PSOVADM
+7 SET PSOEXRX=IEN
MERGE PSOVADM=VADM
DO EN2^PSOMAUEX
MERGE VADM=PSOVADM
KILL PSOEXRX,PSONM,PSONMX
End DoDot:1
+8 KILL PST
SET DIC=52
SET DA=IEN
SET DR=".01:9;10.3;10.6;11;16;17;100"
+9 SET DIQ="PST"
SET DIQ(0)="IE"
DO EN^DIQ1
+10 SET ^TMP($JOB,LIST,"B",PST(52,DA,.01,"E"),IEN)=""
+11 FOR DR=.01,1,2,3,4,5,6,6.5,7,8,9,10.3,10.6,11,16,17,100
Begin DoDot:1
+12 IF PST(52,DA,DR,"E")'=PST(52,DA,DR,"I")
SET ^TMP($JOB,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")_"^"_PST(52,DA,DR,"E")
QUIT
+13 SET ^TMP($JOB,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")
End DoDot:1
+14 SET $PIECE(^TMP($JOB,LIST,DFN,IEN,.01),U,2)=IEN
+15 KILL DA,DR,PST,DIC,DIQ
+16 QUIT
