PSO52API ;BHAM ISC/SAB - Encap II API to return Rx data ; Feb 17, 2023@08:16:38
;;7.0;OUTPATIENT PHARMACY;**213,229,252,387,386,566,441,712**;DEC 1997;Build 20
; Reference to ^PS(55 in ICR #2228
;
RX(DFN,LIST,IEN,RX,NODE,SDATE,EDATE) ;
;DFN: IEN from the PATIENT file (#2) [REQUIRED]
;LIST: Subscript name used in ^TMP global [REQUIRED]
;IEN: Internal prescription number [optional]
;RX#: RX # field (#.01) of the PRESCRIPTION file (#52) [optional]
;NODE: Determines data elements returned [optional]
;SDATE: Start Date [optional]
;EDATE: End Date [optional]
;
Q:'$G(DFN) Q:$G(LIST)=""
N DA,DR,PST,DIC,DIQ,ND,LK,DTE,DAT,I,X,D0 K ^TMP($J,LIST) S ^TMP($J,LIST,DFN,0)=0
I $G(IEN) D PROCESS G CLEAN
I $G(RX)]"",'$G(IEN) S IEN=$O(^PSRX("B",RX,0)) D G CLEAN
.I 'IEN S ^TMP($J,LIST,DFN,0)="-1^NO DATA FOUND" Q
.D PROCESS
D DATE
CLEAN F I=0:0 S I=$O(^TMP($J,LIST,DFN,I)) Q:'I S ^TMP($J,LIST,DFN,0)=^TMP($J,LIST,DFN,0)+1
I ^TMP($J,LIST,DFN,0)=0 S ^TMP($J,LIST,DFN,0)="-1^NO DATA FOUND"
K DA,DR,DIC,ND,DAT,PST,LK,DIQ,DTE,I,X
Q
PROCESS ;
I DFN'=$P($G(^PSRX(IEN,0)),"^",2) S ^TMP($J,LIST,IEN,0)="-1^NO DATA FOUND (MISMATCHED PATIENT)" Q
I $G(^PSRX(IEN,0))']"" S ^TMP($J,LIST,IEN,0)="-1^NO RX DATA FOUND" Q
;
; - Rx Auto Expiration
N RXSTS,RXEXPDT
S RXSTS=+$G(^PSRX(IEN,"STA")),RXEXPDT=$$GET1^DIQ(52,IEN,26,"I")
I (RXSTS<11)!(RXSTS=16),(RXEXPDT<DT) D
.S RXSTS=11 N DIE,DIC,DR,DA,STAT,PHARMST,COMM
.S DIE=52,DA=IEN,DR="100////11" D ^DIE K DIE,DIC,DR
.D ECAN^PSOUTL(IEN)
.S STAT="SC",PHARMST="ZE",COMM="Medication Expired on "_$$FMTE^XLFDT(RXEXPDT,2)
.D EN^PSOHLSN1(IEN,STAT,PHARMST,COMM)
;
I $G(NODE)']"" D ZE,TW,TH,MI,ST,RF,CM,AT,LB,CPRS,PT^PSO52B,SD^PSO52B,TB^PSO52B,OI^PSO52B,MLT^PSO52B,IND S DAT="I" D IB Q
D ST F LK=1:1:$L(NODE,",") S DAT=$P(NODE,",",LK),ND=$P(DAT,"^") D
.I ND=0 D ZE Q
.I ND=2 D ZE,TW Q
.I ND=3 D TW,TH Q
.I ND="R" D RF Q
.I ND="I" D IB Q
.I ND="P" D PT^PSO52B Q
.I ND="O" D OI^PSO52B Q
.I ND="T" D TB^PSO52B Q
.I ND="L" D LB Q
.I ND="S" D SD^PSO52B Q
.I ND="M" D MI Q
.I ND="C" D CM Q
.I ND="A" D AT Q
.I ND="ST" D ST Q
.I ND="CPRS" D CPRS Q
.I ND="ICD" D MLT^PSO52B Q
.I ND="IND" D IND Q
.S ^TMP($J,LIST,DFN,IEN,"INVALID REQUEST",ND)="Invalid Data Requested"
Q
ZE ;zero
K PST S DIC=52,DA=IEN,DR=".01:9;10.3;10.6;11;14;16;17" D DIQ
F DR=.01,1,2,3,4,5,6,6.5,7,8,9,10.3,10.6,11,14,16,17 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")
K DA,DR,PST,DIC,DIQ
Q
TW ;two
Q:'$D(^PSRX(IEN,2))
K PST S DIC=52,DA=IEN,DR="20:31;32.1;32.2;32.3;104" D DIQ
F DR=20,21,22,23,24,25,26,27,28,29,30,31,32.1,32.2,32.3,104 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")
K DA,DR,PST,DIC,DIQ
Q
TH ;three
Q:'$D(^PSRX(IEN,3))
K PST S DIC=52,DA=IEN,DR="12;26.1;34.1;101;102;102.1;102.2;109;112" D DIQ
F DR=12,26.1,34.1,101,102,102.1,102.2,109,112 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")
K DA,DR,PST,DIC,DIQ
Q
MI ;sig
I $P($G(^PSRX(IEN,"SIG")),"^",2) D Q
.I '$O(^PSRX(IEN,"SIG1",0)) S ^TMP($J,LIST,DFN,IEN,"M",0)="-1^NO DATA FOUND" Q
.F I=0:0 S I=$O(^PSRX(IEN,"SIG1",I)) Q:'I S ^TMP($J,LIST,DFN,IEN,"M",I,0)=^PSRX(IEN,"SIG1",I,0),^TMP($J,LIST,DFN,IEN,"M",0)=$G(^TMP($J,LIST,DFN,IEN,"M",0))+1
I $P($G(^PSRX(IEN,"SIG")),"^")']"" S ^TMP($J,LIST,DFN,IEN,"M",0)="-1^NO DATA FOUND" Q
S X=$P($G(^PSRX(IEN,"SIG")),"^") D SIG^PSOHELP S ^TMP($J,LIST,DFN,IEN,"M",1,0)=$E(INS1,2,9999999),^TMP($J,LIST,DFN,IEN,"M",0)=1
K X,INS1
Q
ST ;status
I DT>$P(^PSRX(IEN,2),"^",6),$P(^PSRX(IEN,"STA"),"^")<11 D
.N PSOEXRX,PSOEXSTA,ORN,PIFN,PSUSD,PRFDT,PDA,PSST
.S PSOEXRX=IEN D EN2^PSOMAUEX K PSOEXRX,PSONM,PSONMX
K PST S DIC=52,DA=IEN,DR=".01;100" D DIQ
I PST(52,DA,100,"E")="DRUG INTERACTIONS" S PST(52,DA,100,"E")="NON-VERIFIED"
S ^TMP($J,LIST,DFN,IEN,100)=PST(52,DA,100,"I")_"^"_PST(52,DA,100,"E")
I PST(52,DA,100,"E")="ACTIVE",$G(^PSRX(DA,"PARK")),(LIST="OROCLST"!(LIST["MHV")!($E(LIST,1,4)="GMTS")) S ^TMP($J,LIST,DFN,IEN,100)=^TMP($J,LIST,DFN,IEN,100)_"/PARKED"
S ^TMP($J,LIST,"B",PST(52,DA,.01,"E"),IEN)=""
K DA,DR,PST,DIC,DIQ
Q
RF ;refill
I '$O(^PSRX(IEN,1,0)) S ^TMP($J,LIST,DFN,IEN,"RF",0)="-1^NO DATA FOUND" Q
I $P($G(DAT),"^",3) S DA(52.1)=$P(DAT,"^",3) D RFD K DA,DR,PST,DIC,DIQ Q
F RF=0:0 S RF=$O(^PSRX(IEN,1,RF)) Q:'RF S DA(52.1)=RF D RFD
K DA,DR,PST,DIC,DIQ,RF
Q
RFD K PST S DR(52.1)=".01:8;10.1;11;12;13;14;15;17;23",DIC=52,DA=IEN,DR=52 D DIQ
I $P($G(DAT),"^",3),'$G(PST(52.1,DA(52.1),.01,"I")) S ^TMP($J,LIST,DFN,IEN,"RF",0)="-1^NO DATA FOUND" Q
S ^TMP($J,LIST,DFN,IEN,"RF",0)=$G(^TMP($J,LIST,DFN,IEN,"RF",0))+1
F DR=.01,1,1.1,1.2,2,3,4,5,6,7,8,10.1,11,12,13,14,15,17,23 D
.I PST(52.1,DA(52.1),DR,"E")'=PST(52.1,DA(52.1),DR,"I") S ^TMP($J,LIST,DFN,IEN,"RF",DA(52.1),DR)=PST(52.1,DA(52.1),DR,"I")_"^"_PST(52.1,DA(52.1),DR,"E") Q
.S ^TMP($J,LIST,DFN,IEN,"RF",DA(52.1),DR)=PST(52.1,DA(52.1),DR,"I")
Q
IB ;ib ori
I $P($G(DAT),"^",2)="R" D IBR Q
I $G(^PSRX(IEN,"IB"))']"" S ^TMP($J,LIST,DFN,IEN,"IB",0)="-1^NO DATA FOUND" Q
K PST S DIC=52,DA=IEN,DR="105;106;106.5;106.6" D DIQ
F DR=105,106,106.5,106.6 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,"E")
K DA,DR,PST,DIC,DIQ
I $P($G(DAT),"^",2)="" D IBR Q
Q
IBR ;ib ref
I '$O(^PSRX(IEN,1,0)) S ^TMP($J,LIST,DFN,IEN,"IB",0)="-1^NO DATA FOUND" Q
I $P($G(DAT),"^",2)="R",$P($G(DAT),"^",3) S DA(52.1)=$P(DAT,"^",3) D IBS K DA,DR,PST,DIC,DIQ Q
N IB F IB=0:0 S IB=$O(^PSRX(IEN,1,IB)) Q:'IB S DA(52.1)=IB D IBS
I '$G(^TMP($J,LIST,DFN,IEN,"IB",0)) K ^TMP($J,LIST,DFN,IEN,"IB") S ^TMP($J,LIST,DFN,IEN,"IB",0)="-1^NO DATA FOUND"
K DA,DR,PST,DIC,DIQ,IB
Q
IBS I $P($G(DAT),"^",3),'$G(^PSRX(IEN,1,DA(52.1),"IB")) S ^TMP($J,LIST,DFN,IEN,"IB",0)="-1^NO DATA FOUND" Q
I '$D(^PSRX(IEN,1,DA(52.1),"IB")) S ^TMP($J,LIST,DFN,IEN,"IB",DA(52.1),0)="-1^NO DATA FOUND" Q
K PST S DR(52.1)="9;9.1",DIC=52,DA=IEN,DR=52 D DIQ
S ^TMP($J,LIST,DFN,IEN,"IB",0)=$G(^TMP($J,LIST,DFN,IEN,"IB",0))+1
F DR=9,9.1 D
.I PST(52.1,DA(52.1),DR,"E")'=PST(52.1,DA(52.1),DR,"I") S ^TMP($J,LIST,DFN,IEN,"IB",DA(52.1),DR)=PST(52.1,DA(52.1),DR,"I")_"^"_PST(52.1,DA(52.1),DR,"E") Q
.S ^TMP($J,LIST,DFN,IEN,"IB",DA(52.1),DR)=PST(52.1,DA(52.1),DR,"I")
Q
CM ;cmop
I '$O(^PSRX(IEN,4,0)) S ^TMP($J,LIST,DFN,IEN,"C",0)="-1^NO DATA FOUND" Q
N CM F CM=0:0 S CM=$O(^PSRX(IEN,4,CM)) Q:'CM S DA(52.01)=CM D CMP
K DA,DR,PST,DIC,DIQ,CM
Q
CMP S ^TMP($J,LIST,DFN,IEN,"C",0)=$G(^TMP($J,LIST,DFN,IEN,"C",0))+1
K PST S DR(52.01)=".01;2;3;4;9:12",DIC=52,DA=IEN,DR=400 D DIQ
F DR=.01,2,3,4,9,10,11,12 D
.I PST(52.01,DA(52.01),DR,"E")'=PST(52.01,DA(52.01),DR,"I") S ^TMP($J,LIST,DFN,IEN,"C",DA(52.01),DR)=PST(52.01,DA(52.01),DR,"I")_"^"_PST(52.01,DA(52.01),DR,"E") Q
.S ^TMP($J,LIST,DFN,IEN,"C",DA(52.01),DR)=PST(52.01,DA(52.01),DR,"I")
Q
AT ;activity log
I '$O(^PSRX(IEN,"A",0)) S ^TMP($J,LIST,DFN,IEN,"A",0)="-1^NO DATA FOUND" Q
N AT F AT=0:0 S AT=$O(^PSRX(IEN,"A",AT)) Q:'AT S DA(52.3)=AT D ATP
K DA,DR,PST,DIC,DIQ,AT
Q
ATP K PST S DR(52.3)=".01;.02;.03;.04;.05" S DIC=52,DA=IEN,DR=40 D DIQ
S ^TMP($J,LIST,DFN,IEN,"A",0)=$G(^TMP($J,LIST,DFN,IEN,"A",0))+1
F DR=.01,.02,.03,.04,.05 D
.I DR=.04 S ^TMP($J,LIST,DFN,IEN,"A",DA(52.3),DR)=PST(52.3,DA(52.3),DR,"E") Q
.I PST(52.3,DA(52.3),DR,"E")'=PST(52.3,DA(52.3),DR,"I") S ^TMP($J,LIST,DFN,IEN,"A",DA(52.3),DR)=PST(52.3,DA(52.3),DR,"I")_"^"_PST(52.3,DA(52.3),DR,"E") Q
.S ^TMP($J,LIST,DFN,IEN,"A",DA(52.3),DR)=PST(52.3,DA(52.3),DR,"I")
I $O(^PSRX(IEN,"A",AT,2,0)) D OC
Q
OC ;Activity Log Other Comments
N PSOOC,PSOOCD
F PSOOC=0:0 S PSOOC=$O(^PSRX(IEN,"A",DA(52.3),2,PSOOC)) Q:'PSOOC D
.S PSOOCD=$G(^PSRX(IEN,"A",DA(52.3),2,PSOOC,0)) I PSOOCD'="" S ^TMP($J,LIST,DFN,IEN,"A",DA(52.3),"OC",PSOOC,.01)=PSOOCD
Q
LB ;label log
I '$O(^PSRX(IEN,"L",0)) S ^TMP($J,LIST,DFN,IEN,"L",0)="-1^NO DATA FOUND" Q
N LB F LB=0:0 S LB=$O(^PSRX(IEN,"L",LB)) Q:'LB S DA(52.032)=LB D LBP
K DA,DR,PST,DIC,DIQ,LB
Q
LBP S ^TMP($J,LIST,DFN,IEN,"L",0)=$G(^TMP($J,LIST,DFN,IEN,"L",0))+1
K PST S DR(52.032)=".01;1;2;3;4" S DIC=52,DA=IEN,DR=32 D DIQ
F DR=.01,1,2,3,4 D
.I DR=1 S ^TMP($J,LIST,DFN,IEN,"L",DA(52.032),DR)=PST(52.032,DA(52.032),DR,"E") Q
.I PST(52.032,DA(52.032),DR,"E")'=PST(52.032,DA(52.032),DR,"I") S ^TMP($J,LIST,DFN,IEN,"L",DA(52.032),DR)=PST(52.032,DA(52.032),DR,"I")_"^"_PST(52.032,DA(52.032),DR,"E") Q
.S ^TMP($J,LIST,DFN,IEN,"L",DA(52.032),DR)=PST(52.032,DA(52.032),DR,"I")
K DA,DR,PST,DIC,DIQ
Q
CPRS ;CPRS number
K PST S DIC=52,DA=IEN,DR=39.3 D DIQ
I $G(PST(52,DA,DR,"E"))']"" S ^TMP($J,LIST,DFN,DA,DR)="" Q
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")
K DA,DR,PST,DIC,DIQ
Q
DATE ;date range
I $G(SDATE) S DTE=SDATE-1 D Q
.I $G(EDATE) D Q
..F S DTE=$O(^PS(55,DFN,"P","A",DTE)) Q:'DTE!(DTE>EDATE) F IEN=0:0 S IEN=$O(^PS(55,DFN,"P","A",DTE,IEN)) Q:'IEN D:$P($G(^PSRX(IEN,"STA")),"^")'=13 PROCESS
.F S DTE=$O(^PS(55,DFN,"P","A",DTE)) Q:'DTE F IEN=0:0 S IEN=$O(^PS(55,DFN,"P","A",DTE,IEN)) Q:'IEN D:$P($G(^PSRX(IEN,"STA")),"^")'=13 PROCESS
I $G(EDATE),'$G(SDATE) S DTE=DT-1 D Q
.F S DTE=$O(^PS(55,DFN,"P","A",DTE)) Q:'DTE!(DTE>EDATE) F IEN=0:0 S IEN=$O(^PS(55,DFN,"P","A",DTE,IEN)) Q:'IEN D:$P($G(^PSRX(IEN,"STA")),"^")'=13 PROCESS
S DTE=DT-1 F S DTE=$O(^PS(55,DFN,"P","A",DTE)) Q:'DTE F IEN=0:0 S IEN=$O(^PS(55,DFN,"P","A",DTE,IEN)) Q:'IEN D:$P($G(^PSRX(IEN,"STA")),"^")'=13 PROCESS
Q
PROF(DFN,LIST,SDATE,EDATE) ;
D ^PSO52AP1
Q
IND ;Indication
S:$P($G(^PSRX(IEN,"IND")),U)]"" ^TMP($J,LIST,DFN,IEN,"IND")=$P($G(^PSRX(IEN,"IND")),U,1,2)
Q
DIQ ;process fields
S DIQ="PST",DIQ(0)="IE" D EN^DIQ1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSO52API 10140 printed Apr 09, 2024@21:29:03 Page 2
PSO52API ;BHAM ISC/SAB - Encap II API to return Rx data ; Feb 17, 2023@08:16:38
+1 ;;7.0;OUTPATIENT PHARMACY;**213,229,252,387,386,566,441,712**;DEC 1997;Build 20
+2 ; Reference to ^PS(55 in ICR #2228
+3 ;
RX(DFN,LIST,IEN,RX,NODE,SDATE,EDATE) ;
+1 ;DFN: IEN from the PATIENT file (#2) [REQUIRED]
+2 ;LIST: Subscript name used in ^TMP global [REQUIRED]
+3 ;IEN: Internal prescription number [optional]
+4 ;RX#: RX # field (#.01) of the PRESCRIPTION file (#52) [optional]
+5 ;NODE: Determines data elements returned [optional]
+6 ;SDATE: Start Date [optional]
+7 ;EDATE: End Date [optional]
+8 ;
+9 if '$GET(DFN)
QUIT
if $GET(LIST)=""
QUIT
+10 NEW DA,DR,PST,DIC,DIQ,ND,LK,DTE,DAT,I,X,D0
KILL ^TMP($JOB,LIST)
SET ^TMP($JOB,LIST,DFN,0)=0
+11 IF $GET(IEN)
DO PROCESS
GOTO CLEAN
+12 IF $GET(RX)]""
IF '$GET(IEN)
SET IEN=$ORDER(^PSRX("B",RX,0))
Begin DoDot:1
+13 IF 'IEN
SET ^TMP($JOB,LIST,DFN,0)="-1^NO DATA FOUND"
QUIT
+14 DO PROCESS
End DoDot:1
GOTO CLEAN
+15 DO DATE
CLEAN FOR I=0:0
SET I=$ORDER(^TMP($JOB,LIST,DFN,I))
if 'I
QUIT
SET ^TMP($JOB,LIST,DFN,0)=^TMP($JOB,LIST,DFN,0)+1
+1 IF ^TMP($JOB,LIST,DFN,0)=0
SET ^TMP($JOB,LIST,DFN,0)="-1^NO DATA FOUND"
+2 KILL DA,DR,DIC,ND,DAT,PST,LK,DIQ,DTE,I,X
+3 QUIT
PROCESS ;
+1 IF DFN'=$PIECE($GET(^PSRX(IEN,0)),"^",2)
SET ^TMP($JOB,LIST,IEN,0)="-1^NO DATA FOUND (MISMATCHED PATIENT)"
QUIT
+2 IF $GET(^PSRX(IEN,0))']""
SET ^TMP($JOB,LIST,IEN,0)="-1^NO RX DATA FOUND"
QUIT
+3 ;
+4 ; - Rx Auto Expiration
+5 NEW RXSTS,RXEXPDT
+6 SET RXSTS=+$GET(^PSRX(IEN,"STA"))
SET RXEXPDT=$$GET1^DIQ(52,IEN,26,"I")
+7 IF (RXSTS<11)!(RXSTS=16)
IF (RXEXPDT<DT)
Begin DoDot:1
+8 SET RXSTS=11
NEW DIE,DIC,DR,DA,STAT,PHARMST,COMM
+9 SET DIE=52
SET DA=IEN
SET DR="100////11"
DO ^DIE
KILL DIE,DIC,DR
+10 DO ECAN^PSOUTL(IEN)
+11 SET STAT="SC"
SET PHARMST="ZE"
SET COMM="Medication Expired on "_$$FMTE^XLFDT(RXEXPDT,2)
+12 DO EN^PSOHLSN1(IEN,STAT,PHARMST,COMM)
End DoDot:1
+13 ;
+14 IF $GET(NODE)']""
DO ZE
DO TW
DO TH
DO MI
DO ST
DO RF
DO CM
DO AT
DO LB
DO CPRS
DO PT^PSO52B
DO SD^PSO52B
DO TB^PSO52B
DO OI^PSO52B
DO MLT^PSO52B
DO IND
SET DAT="I"
DO IB
QUIT
+15 DO ST
FOR LK=1:1:$LENGTH(NODE,",")
SET DAT=$PIECE(NODE,",",LK)
SET ND=$PIECE(DAT,"^")
Begin DoDot:1
+16 IF ND=0
DO ZE
QUIT
+17 IF ND=2
DO ZE
DO TW
QUIT
+18 IF ND=3
DO TW
DO TH
QUIT
+19 IF ND="R"
DO RF
QUIT
+20 IF ND="I"
DO IB
QUIT
+21 IF ND="P"
DO PT^PSO52B
QUIT
+22 IF ND="O"
DO OI^PSO52B
QUIT
+23 IF ND="T"
DO TB^PSO52B
QUIT
+24 IF ND="L"
DO LB
QUIT
+25 IF ND="S"
DO SD^PSO52B
QUIT
+26 IF ND="M"
DO MI
QUIT
+27 IF ND="C"
DO CM
QUIT
+28 IF ND="A"
DO AT
QUIT
+29 IF ND="ST"
DO ST
QUIT
+30 IF ND="CPRS"
DO CPRS
QUIT
+31 IF ND="ICD"
DO MLT^PSO52B
QUIT
+32 IF ND="IND"
DO IND
QUIT
+33 SET ^TMP($JOB,LIST,DFN,IEN,"INVALID REQUEST",ND)="Invalid Data Requested"
End DoDot:1
+34 QUIT
ZE ;zero
+1 KILL PST
SET DIC=52
SET DA=IEN
SET DR=".01:9;10.3;10.6;11;14;16;17"
DO DIQ
+2 FOR DR=.01,1,2,3,4,5,6,6.5,7,8,9,10.3,10.6,11,14,16,17
Begin DoDot:1
+3 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
+4 SET ^TMP($JOB,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")
End DoDot:1
+5 KILL DA,DR,PST,DIC,DIQ
+6 QUIT
TW ;two
+1 if '$DATA(^PSRX(IEN,2))
QUIT
+2 KILL PST
SET DIC=52
SET DA=IEN
SET DR="20:31;32.1;32.2;32.3;104"
DO DIQ
+3 FOR DR=20,21,22,23,24,25,26,27,28,29,30,31,32.1,32.2,32.3,104
Begin DoDot:1
+4 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
+5 SET ^TMP($JOB,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")
End DoDot:1
+6 KILL DA,DR,PST,DIC,DIQ
+7 QUIT
TH ;three
+1 if '$DATA(^PSRX(IEN,3))
QUIT
+2 KILL PST
SET DIC=52
SET DA=IEN
SET DR="12;26.1;34.1;101;102;102.1;102.2;109;112"
DO DIQ
+3 FOR DR=12,26.1,34.1,101,102,102.1,102.2,109,112
Begin DoDot:1
+4 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
+5 SET ^TMP($JOB,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")
End DoDot:1
+6 KILL DA,DR,PST,DIC,DIQ
+7 QUIT
MI ;sig
+1 IF $PIECE($GET(^PSRX(IEN,"SIG")),"^",2)
Begin DoDot:1
+2 IF '$ORDER(^PSRX(IEN,"SIG1",0))
SET ^TMP($JOB,LIST,DFN,IEN,"M",0)="-1^NO DATA FOUND"
QUIT
+3 FOR I=0:0
SET I=$ORDER(^PSRX(IEN,"SIG1",I))
if 'I
QUIT
SET ^TMP($JOB,LIST,DFN,IEN,"M",I,0)=^PSRX(IEN,"SIG1",I,0)
SET ^TMP($JOB,LIST,DFN,IEN,"M",0)=$GET(^TMP($JOB,LIST,DFN,IEN,"M",0))+1
End DoDot:1
QUIT
+4 IF $PIECE($GET(^PSRX(IEN,"SIG")),"^")']""
SET ^TMP($JOB,LIST,DFN,IEN,"M",0)="-1^NO DATA FOUND"
QUIT
+5 SET X=$PIECE($GET(^PSRX(IEN,"SIG")),"^")
DO SIG^PSOHELP
SET ^TMP($JOB,LIST,DFN,IEN,"M",1,0)=$EXTRACT(INS1,2,9999999)
SET ^TMP($JOB,LIST,DFN,IEN,"M",0)=1
+6 KILL X,INS1
+7 QUIT
ST ;status
+1 IF DT>$PIECE(^PSRX(IEN,2),"^",6)
IF $PIECE(^PSRX(IEN,"STA"),"^")<11
Begin DoDot:1
+2 NEW PSOEXRX,PSOEXSTA,ORN,PIFN,PSUSD,PRFDT,PDA,PSST
+3 SET PSOEXRX=IEN
DO EN2^PSOMAUEX
KILL PSOEXRX,PSONM,PSONMX
End DoDot:1
+4 KILL PST
SET DIC=52
SET DA=IEN
SET DR=".01;100"
DO DIQ
+5 IF PST(52,DA,100,"E")="DRUG INTERACTIONS"
SET PST(52,DA,100,"E")="NON-VERIFIED"
+6 SET ^TMP($JOB,LIST,DFN,IEN,100)=PST(52,DA,100,"I")_"^"_PST(52,DA,100,"E")
+7 IF PST(52,DA,100,"E")="ACTIVE"
IF $GET(^PSRX(DA,"PARK"))
IF (LIST="OROCLST"!(LIST["MHV")!($EXTRACT(LIST,1,4)="GMTS"))
SET ^TMP($JOB,LIST,DFN,IEN,100)=^TMP($JOB,LIST,DFN,IEN,100)_"/PARKED"
+8 SET ^TMP($JOB,LIST,"B",PST(52,DA,.01,"E"),IEN)=""
+9 KILL DA,DR,PST,DIC,DIQ
+10 QUIT
RF ;refill
+1 IF '$ORDER(^PSRX(IEN,1,0))
SET ^TMP($JOB,LIST,DFN,IEN,"RF",0)="-1^NO DATA FOUND"
QUIT
+2 IF $PIECE($GET(DAT),"^",3)
SET DA(52.1)=$PIECE(DAT,"^",3)
DO RFD
KILL DA,DR,PST,DIC,DIQ
QUIT
+3 FOR RF=0:0
SET RF=$ORDER(^PSRX(IEN,1,RF))
if 'RF
QUIT
SET DA(52.1)=RF
DO RFD
+4 KILL DA,DR,PST,DIC,DIQ,RF
+5 QUIT
RFD KILL PST
SET DR(52.1)=".01:8;10.1;11;12;13;14;15;17;23"
SET DIC=52
SET DA=IEN
SET DR=52
DO DIQ
+1 IF $PIECE($GET(DAT),"^",3)
IF '$GET(PST(52.1,DA(52.1),.01,"I"))
SET ^TMP($JOB,LIST,DFN,IEN,"RF",0)="-1^NO DATA FOUND"
QUIT
+2 SET ^TMP($JOB,LIST,DFN,IEN,"RF",0)=$GET(^TMP($JOB,LIST,DFN,IEN,"RF",0))+1
+3 FOR DR=.01,1,1.1,1.2,2,3,4,5,6,7,8,10.1,11,12,13,14,15,17,23
Begin DoDot:1
+4 IF PST(52.1,DA(52.1),DR,"E")'=PST(52.1,DA(52.1),DR,"I")
SET ^TMP($JOB,LIST,DFN,IEN,"RF",DA(52.1),DR)=PST(52.1,DA(52.1),DR,"I")_"^"_PST(52.1,DA(52.1),DR,"E")
QUIT
+5 SET ^TMP($JOB,LIST,DFN,IEN,"RF",DA(52.1),DR)=PST(52.1,DA(52.1),DR,"I")
End DoDot:1
+6 QUIT
IB ;ib ori
+1 IF $PIECE($GET(DAT),"^",2)="R"
DO IBR
QUIT
+2 IF $GET(^PSRX(IEN,"IB"))']""
SET ^TMP($JOB,LIST,DFN,IEN,"IB",0)="-1^NO DATA FOUND"
QUIT
+3 KILL PST
SET DIC=52
SET DA=IEN
SET DR="105;106;106.5;106.6"
DO DIQ
+4 FOR DR=105,106,106.5,106.6
Begin DoDot:1
+5 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
+6 SET ^TMP($JOB,LIST,DFN,IEN,DR)=PST(52,DA,DR,"E")
End DoDot:1
+7 KILL DA,DR,PST,DIC,DIQ
+8 IF $PIECE($GET(DAT),"^",2)=""
DO IBR
QUIT
+9 QUIT
IBR ;ib ref
+1 IF '$ORDER(^PSRX(IEN,1,0))
SET ^TMP($JOB,LIST,DFN,IEN,"IB",0)="-1^NO DATA FOUND"
QUIT
+2 IF $PIECE($GET(DAT),"^",2)="R"
IF $PIECE($GET(DAT),"^",3)
SET DA(52.1)=$PIECE(DAT,"^",3)
DO IBS
KILL DA,DR,PST,DIC,DIQ
QUIT
+3 NEW IB
FOR IB=0:0
SET IB=$ORDER(^PSRX(IEN,1,IB))
if 'IB
QUIT
SET DA(52.1)=IB
DO IBS
+4 IF '$GET(^TMP($JOB,LIST,DFN,IEN,"IB",0))
KILL ^TMP($JOB,LIST,DFN,IEN,"IB")
SET ^TMP($JOB,LIST,DFN,IEN,"IB",0)="-1^NO DATA FOUND"
+5 KILL DA,DR,PST,DIC,DIQ,IB
+6 QUIT
IBS IF $PIECE($GET(DAT),"^",3)
IF '$GET(^PSRX(IEN,1,DA(52.1),"IB"))
SET ^TMP($JOB,LIST,DFN,IEN,"IB",0)="-1^NO DATA FOUND"
QUIT
+1 IF '$DATA(^PSRX(IEN,1,DA(52.1),"IB"))
SET ^TMP($JOB,LIST,DFN,IEN,"IB",DA(52.1),0)="-1^NO DATA FOUND"
QUIT
+2 KILL PST
SET DR(52.1)="9;9.1"
SET DIC=52
SET DA=IEN
SET DR=52
DO DIQ
+3 SET ^TMP($JOB,LIST,DFN,IEN,"IB",0)=$GET(^TMP($JOB,LIST,DFN,IEN,"IB",0))+1
+4 FOR DR=9,9.1
Begin DoDot:1
+5 IF PST(52.1,DA(52.1),DR,"E")'=PST(52.1,DA(52.1),DR,"I")
SET ^TMP($JOB,LIST,DFN,IEN,"IB",DA(52.1),DR)=PST(52.1,DA(52.1),DR,"I")_"^"_PST(52.1,DA(52.1),DR,"E")
QUIT
+6 SET ^TMP($JOB,LIST,DFN,IEN,"IB",DA(52.1),DR)=PST(52.1,DA(52.1),DR,"I")
End DoDot:1
+7 QUIT
CM ;cmop
+1 IF '$ORDER(^PSRX(IEN,4,0))
SET ^TMP($JOB,LIST,DFN,IEN,"C",0)="-1^NO DATA FOUND"
QUIT
+2 NEW CM
FOR CM=0:0
SET CM=$ORDER(^PSRX(IEN,4,CM))
if 'CM
QUIT
SET DA(52.01)=CM
DO CMP
+3 KILL DA,DR,PST,DIC,DIQ,CM
+4 QUIT
CMP SET ^TMP($JOB,LIST,DFN,IEN,"C",0)=$GET(^TMP($JOB,LIST,DFN,IEN,"C",0))+1
+1 KILL PST
SET DR(52.01)=".01;2;3;4;9:12"
SET DIC=52
SET DA=IEN
SET DR=400
DO DIQ
+2 FOR DR=.01,2,3,4,9,10,11,12
Begin DoDot:1
+3 IF PST(52.01,DA(52.01),DR,"E")'=PST(52.01,DA(52.01),DR,"I")
SET ^TMP($JOB,LIST,DFN,IEN,"C",DA(52.01),DR)=PST(52.01,DA(52.01),DR,"I")_"^"_PST(52.01,DA(52.01),DR,"E")
QUIT
+4 SET ^TMP($JOB,LIST,DFN,IEN,"C",DA(52.01),DR)=PST(52.01,DA(52.01),DR,"I")
End DoDot:1
+5 QUIT
AT ;activity log
+1 IF '$ORDER(^PSRX(IEN,"A",0))
SET ^TMP($JOB,LIST,DFN,IEN,"A",0)="-1^NO DATA FOUND"
QUIT
+2 NEW AT
FOR AT=0:0
SET AT=$ORDER(^PSRX(IEN,"A",AT))
if 'AT
QUIT
SET DA(52.3)=AT
DO ATP
+3 KILL DA,DR,PST,DIC,DIQ,AT
+4 QUIT
ATP KILL PST
SET DR(52.3)=".01;.02;.03;.04;.05"
SET DIC=52
SET DA=IEN
SET DR=40
DO DIQ
+1 SET ^TMP($JOB,LIST,DFN,IEN,"A",0)=$GET(^TMP($JOB,LIST,DFN,IEN,"A",0))+1
+2 FOR DR=.01,.02,.03,.04,.05
Begin DoDot:1
+3 IF DR=.04
SET ^TMP($JOB,LIST,DFN,IEN,"A",DA(52.3),DR)=PST(52.3,DA(52.3),DR,"E")
QUIT
+4 IF PST(52.3,DA(52.3),DR,"E")'=PST(52.3,DA(52.3),DR,"I")
SET ^TMP($JOB,LIST,DFN,IEN,"A",DA(52.3),DR)=PST(52.3,DA(52.3),DR,"I")_"^"_PST(52.3,DA(52.3),DR,"E")
QUIT
+5 SET ^TMP($JOB,LIST,DFN,IEN,"A",DA(52.3),DR)=PST(52.3,DA(52.3),DR,"I")
End DoDot:1
+6 IF $ORDER(^PSRX(IEN,"A",AT,2,0))
DO OC
+7 QUIT
OC ;Activity Log Other Comments
+1 NEW PSOOC,PSOOCD
+2 FOR PSOOC=0:0
SET PSOOC=$ORDER(^PSRX(IEN,"A",DA(52.3),2,PSOOC))
if 'PSOOC
QUIT
Begin DoDot:1
+3 SET PSOOCD=$GET(^PSRX(IEN,"A",DA(52.3),2,PSOOC,0))
IF PSOOCD'=""
SET ^TMP($JOB,LIST,DFN,IEN,"A",DA(52.3),"OC",PSOOC,.01)=PSOOCD
End DoDot:1
+4 QUIT
LB ;label log
+1 IF '$ORDER(^PSRX(IEN,"L",0))
SET ^TMP($JOB,LIST,DFN,IEN,"L",0)="-1^NO DATA FOUND"
QUIT
+2 NEW LB
FOR LB=0:0
SET LB=$ORDER(^PSRX(IEN,"L",LB))
if 'LB
QUIT
SET DA(52.032)=LB
DO LBP
+3 KILL DA,DR,PST,DIC,DIQ,LB
+4 QUIT
LBP SET ^TMP($JOB,LIST,DFN,IEN,"L",0)=$GET(^TMP($JOB,LIST,DFN,IEN,"L",0))+1
+1 KILL PST
SET DR(52.032)=".01;1;2;3;4"
SET DIC=52
SET DA=IEN
SET DR=32
DO DIQ
+2 FOR DR=.01,1,2,3,4
Begin DoDot:1
+3 IF DR=1
SET ^TMP($JOB,LIST,DFN,IEN,"L",DA(52.032),DR)=PST(52.032,DA(52.032),DR,"E")
QUIT
+4 IF PST(52.032,DA(52.032),DR,"E")'=PST(52.032,DA(52.032),DR,"I")
SET ^TMP($JOB,LIST,DFN,IEN,"L",DA(52.032),DR)=PST(52.032,DA(52.032),DR,"I")_"^"_PST(52.032,DA(52.032),DR,"E")
QUIT
+5 SET ^TMP($JOB,LIST,DFN,IEN,"L",DA(52.032),DR)=PST(52.032,DA(52.032),DR,"I")
End DoDot:1
+6 KILL DA,DR,PST,DIC,DIQ
+7 QUIT
CPRS ;CPRS number
+1 KILL PST
SET DIC=52
SET DA=IEN
SET DR=39.3
DO DIQ
+2 IF $GET(PST(52,DA,DR,"E"))']""
SET ^TMP($JOB,LIST,DFN,DA,DR)=""
QUIT
+3 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
+4 SET ^TMP($JOB,LIST,DFN,IEN,DR)=PST(52,DA,DR,"I")
+5 KILL DA,DR,PST,DIC,DIQ
+6 QUIT
DATE ;date range
+1 IF $GET(SDATE)
SET DTE=SDATE-1
Begin DoDot:1
+2 IF $GET(EDATE)
Begin DoDot:2
+3 FOR
SET DTE=$ORDER(^PS(55,DFN,"P","A",DTE))
if 'DTE!(DTE>EDATE)
QUIT
FOR IEN=0:0
SET IEN=$ORDER(^PS(55,DFN,"P","A",DTE,IEN))
if 'IEN
QUIT
if $PIECE($GET(^PSRX(IEN,"STA")),"^")'=13
DO PROCESS
End DoDot:2
QUIT
+4 FOR
SET DTE=$ORDER(^PS(55,DFN,"P","A",DTE))
if 'DTE
QUIT
FOR IEN=0:0
SET IEN=$ORDER(^PS(55,DFN,"P","A",DTE,IEN))
if 'IEN
QUIT
if $PIECE($GET(^PSRX(IEN,"STA")),"^")'=13
DO PROCESS
End DoDot:1
QUIT
+5 IF $GET(EDATE)
IF '$GET(SDATE)
SET DTE=DT-1
Begin DoDot:1
+6 FOR
SET DTE=$ORDER(^PS(55,DFN,"P","A",DTE))
if 'DTE!(DTE>EDATE)
QUIT
FOR IEN=0:0
SET IEN=$ORDER(^PS(55,DFN,"P","A",DTE,IEN))
if 'IEN
QUIT
if $PIECE($GET(^PSRX(IEN,"STA")),"^")'=13
DO PROCESS
End DoDot:1
QUIT
+7 SET DTE=DT-1
FOR
SET DTE=$ORDER(^PS(55,DFN,"P","A",DTE))
if 'DTE
QUIT
FOR IEN=0:0
SET IEN=$ORDER(^PS(55,DFN,"P","A",DTE,IEN))
if 'IEN
QUIT
if $PIECE($GET(^PSRX(IEN,"STA")),"^")'=13
DO PROCESS
+8 QUIT
PROF(DFN,LIST,SDATE,EDATE) ;
+1 DO ^PSO52AP1
+2 QUIT
IND ;Indication
+1 if $PIECE($GET(^PSRX(IEN,"IND")),U)]""
SET ^TMP($JOB,LIST,DFN,IEN,"IND")=$PIECE($GET(^PSRX(IEN,"IND")),U,1,2)
+2 QUIT
DIQ ;process fields
+1 SET DIQ="PST"
SET DIQ(0)="IE"
DO EN^DIQ1
+2 QUIT
