- 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 Apr 23, 2025@18:37:35 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
