PSOMHV1 ;BIR/MHA - MHV API, Build patient medication ; 4/20/05 8:54am
;;7.0;OUTPATIENT PHARMACY;**204**;DEC 1997
;External reference ^PS(55 supported by DBIA 2228
;External reference ^PSDRUG( supported by DBIA 221
;External reference to ^PS(51 supported by DBIA 2224
;External reference to ^PS(51.2 supported by DBIA 2226
;External reference to ^PS(50.7 supported by DBIA 2223
;External reference to ^PS(50.606 supported by DBIA 2174
; Input variables: dfn, start date, cut off date
EN(DFN,BDT,EDT) ;entry point to return medication list
Q:'$G(DFN)
N DRG,DRGN,EXD,I,IFN,MIG,LSTFD,ORD,PEN,PSOBD,PSOED,PSODD,PSOOI,PSOSD,RX,RX0,RX2,RX3,TFN,TD,TR,TRM,SC,SCH,ST0,STA,PSODIV
I '$G(DT) S DT=$$DT^XLFDT
K ^TMP("PSO",$J) S PSOBD=$G(BDT),PSOED=$G(EDT)
I +$G(PSOBD)<1 S X1=DT,X2=-120 D C^%DTC S PSOBD=X
S EXD=PSOBD-1
I PSOED="" S PSOED=9999999
F S EXD=$O(^PS(55,DFN,"P","A",EXD)) Q:'EXD Q:EXD>PSOED D
.S RX=0 F S RX=$O(^PS(55,DFN,"P","A",EXD,RX)) Q:'RX D:$D(^PSRX(RX,0)) GET
S STA="ACT^NVR^REF^HLD^NVR^SUS^^^^^^EXP^DCD^DEL^DCD^DCD^HLD"
S DRG="" F S DRG=$O(PSOSD(DRG)) Q:DRG="" D:$G(PSOSD(DRG))]""
.S PSOSD($P(STA,"^",$P(PSOSD(DRG),"^",2)+1),DRG)=PSOSD(DRG) K PSOSD(DRG)
D PEN D:$D(PSOSD) BLD
Q
EN2(DFN,RXLIST) ;Entry point to return data for specified RX #s
Q:DFN<1
Q:'RXLIST
N DRG,DRGN,EXD,I,IFN,MIG,LSTFD,ORD,PEN,PSOBD,PSOED,PSODD,PSOOI,PSOSD,RX,RX0,RX2,RX3,TFN,TD,TR,TRM,SC,SCH,ST0,STA,PSORX,J,PSOERR,RX,PSRXD,PSODIV,PSOSTA
I '$G(DT) S DT=$$DT^XLFDT
K ^TMP("PSO",$J)
S PSOSTA="ACT^NVR^REF^HLD^NVR^SUS^^^^^^EXP^DCD^DEL^DCD^DCD^HLD"
F J=1:1 S PSORX=$P(RXLIST,"^",J) Q:PSORX="" D
. I '$D(^PSRX("B",PSORX)) Q
. I $O(^PSRX("B",PSORX,""))="" Q
. S RX=$O(^PSRX("B",PSORX,"")),PSRXD=$G(^PSRX(RX,0))
. Q:PSRXD=""
. Q:$P(PSRXD,"^",2)'=DFN
. Q:$P($G(^PSRX(RX,"STA")),"^")=13
. Q:$P($G(^PSRX(RX,"STA")),"^")=15
. Q:'$D(^PSDRUG($P(PSRXD,"^",6),0))
. S IFN=RX,TR=$P(PSOSTA,"^",$P($G(^PSRX(RX,"STA")),"^")+1)
. S TD=$P(^PSDRUG($P(PSRXD,"^",6),0),"^")
. D RXD
. Q
Q
;
EN3(DFN,BDT,EDT) ;entry point to return prescription history
Q:'$G(DFN)
N DRG,DRGN,EXD,I,IFN,MIG,LSTFD,ORD,PEN,PSOBD,PSOED,PSODD,PSOOI,PSOSD,RX,RX0,RX2,RX3,TFN,TD,TR,TRM,SC,SCH,ST0,STA,PSODIV
I '$G(DT) S DT=$$DT^XLFDT
K ^TMP("PSO",$J) S PSOBD=$G(BDT),PSOED=$G(EDT)
I +$G(PSOBD)<1 S X1=DT,X2=-120 D C^%DTC S PSOBD=X
S EXD=PSOBD-1
I PSOED="" S PSOED=9999999
F S EXD=$O(^PS(55,DFN,"P","A",EXD)) Q:'EXD Q:EXD>PSOED D
.S RX=0 F S RX=$O(^PS(55,DFN,"P","A",EXD,RX)) Q:'RX D:$D(^PSRX(RX,0)) GET1
S STA="ACT^NVR^REF^HLD^NVR^SUS^^^^^^EXP^DCD^DEL^DCD^DCD^HLD"
; Uses RX (Rx IEN) instead of DRUG as a subscript in PSOSD and thus
; in ^TMP("PSO",$J). Other entry points use DRUG
S RX="" F S RX=$O(PSOSD(RX)) Q:RX="" D:$G(PSOSD(RX))]""
.S PSOSD($P(STA,"^",$P(PSOSD(RX),"^",2)+1),RX)=PSOSD(RX) K PSOSD(RX)
D:$D(PSOSD) BLD
Q
;
PEN F PEN=0:0 S PEN=$O(^PS(52.41,"P",DFN,PEN)) Q:'PEN D
.S ORD=^PS(52.41,PEN,0) Q:$P(ORD,"^",2)'=DFN S DRG=""
.Q:$P(ORD,"^",3)="DC"!($P(ORD,"^",3)="DE")!($P(ORD,"^",3)="")!($P(ORD,"^",3)="RF")
.S PSOOI=$P(ORD,"^",8),PSODD=+$P(ORD,"^",9)
.S DRG=$S(PSODD:$P($G(^PSDRUG(PSODD,0)),"^"),+PSOOI&('PSODD):$P(^PS(50.7,+PSOOI,0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,+PSOOI,0),"^",2),0),"^"),1:"")
.Q:DRG']""
.I $D(PSOSD("PEN",DRG)) S DRG=DRG_"^"_PEN
.S PSOSD("PEN",DRG)=PEN
Q
GET ;
Q:$P($G(^PSRX(RX,"STA")),"^")=13
Q:$P($G(^PSRX(RX,"STA")),"^")=15
Q:'$P(^PSRX(RX,0),"^",2)
Q:$P(^PSRX(RX,0),"^",2)'=DFN
S RX0=^PSRX(RX,0),RX2=^PSRX(RX,2)
S DRG=$P(^PSRX(RX,0),"^",6),STA=+^("STA") Q:'$D(^PSDRUG(DRG,0))
S DRGN=$P(^PSDRUG(DRG,0),"^"),ST0=$S(STA<12&($P(RX2,"^",6)<DT):11,1:STA)
I $D(PSOSD(DRGN)),ST0>10 Q:$P(PSOSD(DRGN),"^",2)<11 Q:$P(PSOSD(DRGN),"^",2)>10&($P(RX0,"^",13)<$P(^PSRX(+$P(PSOSD(DRGN),"^"),0),"^",13))
I $D(PSOSD(DRGN)),$P(PSOSD(DRGN),"^",2)<10,ST0<10 S PSOSD(DRGN_"^"_RX)=RX_"^"_ST0
E S PSOSD(DRGN)=RX_"^"_ST0
Q
GET1 ;
Q:'$P(^PSRX(RX,0),"^",2)
Q:$P(^PSRX(RX,0),"^",2)'=DFN
S RX0=^PSRX(RX,0),RX2=^PSRX(RX,2)
S DRG=$P(^PSRX(RX,0),"^",6),STA=+^("STA") Q:'$D(^PSDRUG(DRG,0))
S DRGN=$P(^PSDRUG(DRG,0),"^"),ST0=$S(STA<12&($P(RX2,"^",6)<DT):11,1:STA)
S PSOSD(RX)=RX_"^"_ST0
Q
BLD ;
S TR="" F S TR=$O(PSOSD(TR)) Q:TR="" D
.S TFN=0,TD="" F S TD=$O(PSOSD(TR,TD)) Q:TD="" S IFN=+PSOSD(TR,TD) D @$S(TR="PEN":"PND",1:"RXD")
Q
RXD ;
Q:'$D(^PSRX(IFN,0))
S RX0=^PSRX(IFN,0),RX2=$G(^(2)),RX3=$G(^(3)),STA=+$G(^("STA")),TRM=0,LSTFD=$P(RX2,"^",2)
S ^TMP("PSO",$J,TR,TD,"RXN",0)=$P(RX0,"^")_"^"_$E($P(RX2,"^",13),1,7)_"^"_$S($P(RX0,"^",11)="W":"W",1:"M")_"^"_$P(RX3,"^",7)
S ^TMP("PSO",$J,TR,TD,"RXN",0)=^TMP("PSO",$J,TR,TD,"RXN",0)_"^"_$S($P($G(^PSRX(IFN,"OR1")),"^",5):$P(^PSRX(IFN,"OR1"),"^",5),1:"")_"^"_$E($P(RX2,"^",2),1,7)_"^"_$E($P(RX2,"^",13),1,7)_"^^"_IFN
S I=0 F S I=$O(^PSRX(IFN,1,I)) Q:'I S TRM=TRM+1,LSTFD=$P(^PSRX(IFN,1,I,0),"^") D
.S ^TMP("PSO",$J,TR,TD,"REF",I,0)=$P(^PSRX(IFN,1,I,0),"^")_"^"_$P(^(0),"^",10)_"^"_$P(^(0),"^",4)_"^"_$E($P(^(0),"^",18),1,7)_"^"_$S($P(^(0),"^",2)="W":"W",1:"M")_"^"_$P(^(0),"^",3)
.I $P(^PSRX(IFN,1,I,0),"^",18) S $P(^TMP("PSO",$J,TR,TD,"RXN",0),"^",2)=$E($P(^PSRX(IFN,1,I,0),"^",18),1,7)
.S ^TMP("PSO",$J,TR,TD,"REF",0)=$G(^TMP("PSO",$J,TR,TD,"REF",0))+1
S I=0 F S I=$O(^PSRX(IFN,"P",I)) Q:'I D
.S ^TMP("PSO",$J,TR,TD,"PAR",I,0)=$P(^PSRX(IFN,"P",I,0),"^")_"^"_$P(^(0),"^",10)_"^"_$P(^(0),"^",4)_"^"_$E($P(^(0),"^",19),1,7)_"^"_$S($P(^(0),"^",2)="W":"W",1:"M")_"^"_$P(^(0),"^",3)
.S ^TMP("PSO",$J,TR,TD,"PAR",0)=$G(^TMP("PSO",$J,TR,TD,"PAR",0))+1
S ^TMP("PSO",$J,TR,TD,0)=$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^")_"^^"_$P(RX2,"^",6)
S ^TMP("PSO",$J,TR,TD,"P",0)=$P(RX0,"^",4)_"^"_$P($G(^VA(200,+$P(RX0,"^",4),0)),"^")
S ST0=$S(STA<12&($P(RX2,"^",6)<DT):11,1:STA)
S SC=$P("ERROR^ACTIVE^NON-VERIFIED^REFILL FILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^DONE^EXPIRED^DISCONTINUED^DELETED^DISCONTINUED^DISCONTINUED (EDIT)^HOLD^","^",ST0+2)
S ^TMP("PSO",$J,TR,TD,0)=^TMP("PSO",$J,TR,TD,0)_"^"_($P(RX0,"^",9)-TRM)_"^"_$P(RX0,"^",13)_"^"_SC_"^"_$P(RX0,"^",8)_"^"_$P(RX0,"^",7)_"^^^"_$P($G(^PSRX(IFN,"OR1")),"^",2)_"^"_LSTFD_"^^"
S ^TMP("PSO",$J,TR,TD,"DD",0)=1,^TMP("PSO",$J,TR,TD,"DD",1,0)=$P(RX0,"^",6)_"^^"
S (SCH,SC)=0
F S SC=$O(^PSRX(IFN,"SCH",SC)) Q:'SC S SCH=SCH+1,^TMP("PSO",$J,TR,TD,"SCH",SCH,0)=$P(^PSRX(IFN,"SCH",SC,0),"^") D
.S ^TMP("PSO",$J,TR,TD,"SCH",0)=$G(^TMP("PSO",$J,TR,TD,"SCH",0))+1
D MDR
S SC=0 I $D(^PSRX(IFN,"SIG")),'$P(^PSRX(IFN,"SIG"),"^",2) S SC=1 S X=$P(^PSRX(IFN,"SIG"),"^") D SIG
I '$G(SC) S SCH=1 D
.S ^TMP("PSO",$J,TR,TD,"SIG",SCH,0)=$G(^PSRX(IFN,"SIG1",1,0)),^TMP("PSO",$J,TR,TD,"SIG",0)=SCH
.F I=1:0 S I=$O(^PSRX(IFN,"SIG1",I)) Q:'I S SCH=SCH+1,^TMP("PSO",$J,TR,TD,"SIG",SCH,0)=^PSRX(IFN,"SIG1",I,0),^TMP("PSO",$J,TR,TD,"SIG",0)=SCH
S (I,SC)=0
F S I=$O(^PSRX(IFN,"PRC",I)) Q:'I S SC=SC+1 D
.S ^TMP("PSO",$J,TR,TD,"PC",SC,0)=^PSRX(IFN,"PRC",I,0),^TMP("PSO",$J,TR,TD,"PC",0)=SC
S PSODIV=$P(RX2,"^",9)
I PSODIV'="",$D(^PS(59,PSODIV,0)) S ^TMP("PSO",$J,TR,TD,"DIV",0)=PSODIV_"^"_^PS(59,PSODIV,0)
Q
MDR ;
S (SCH,SC)=0
F S SC=$O(^PSRX(IFN,"MEDR",SC)) Q:'SC D
.Q:'$D(^PS(51.2,+^PSRX(IFN,"MEDR",SC,0),0)) S SCH=SCH+1
.S ^TMP("PSO",$J,TR,TD,"MDR",SCH,0)=$S($P(^PS(51.2,+^PSRX(IFN,"MEDR",SC,0),0),"^",3)]"":$P(^(0),"^",3),1:$P(^(0),"^"))
.S ^TMP("PSO",$J,TR,TD,"MDR",0)=SCH
Q
PND Q:'$D(^PS(52.41,IFN,0))
S ORD=^PS(52.41,IFN,0) Q:$P(ORD,"^",2)'=DFN
Q:$P(ORD,"^",3)="DC"!($P(ORD,"^",3)="DE")
S PSOOI=+$P(ORD,"^",8),PSODD=+$P(ORD,"^",9)
S DRG=$S(PSODD:$P($G(^PSDRUG(PSODD,0)),"^"),1:$P(^PS(50.7,PSOOI,0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,PSOOI,0),"^",2),0),"^"))
S ^TMP("PSO",$J,TR,TD,0)=DRG
S:PSODD ^TMP("PSO",$J,TR,TD,"DD",0)=1,^TMP("PSO",$J,TR,TD,"DD",1,0)=PSODD_"^^"
S ^TMP("PSO",$J,TR,TD,0)=^TMP("PSO",$J,TR,TD,0)_"^"_$S($G(^PS(51.2,+$P(ORD,"^",15),0))]"":$P(^PS(51.2,+$P(ORD,"^",15),0),"^",3),1:"")
S ^TMP("PSO",$J,TR,TD,0)=^TMP("PSO",$J,TR,TD,0)_"^^"_$P(ORD,"^",11)_"^"_$P($P(ORD,"^",6),".")_"^"_$S($P(ORD,"^",3)'="HD":"PENDING",1:" ONHOLD")_"^^"_$P(ORD,"^",10)
S $P(^TMP("PSO",$J,TR,TD,0),"^",11)=$P(ORD,"^")
S (SC,SCH)=0 F S SC=$O(^PS(52.41,IFN,1,SC)) Q:'SC D
.S SCH=SCH+1,^TMP("PSO",$J,TR,TD,"SCH",SCH,0)=$P(^PS(52.41,IFN,1,SC,1),"^"),^TMP("PSO",$J,TR,TD,"SCH",0)=SCH
S (SC,SCH)=0 F S SC=$O(^PS(52.41,IFN,"SIG",SC)) Q:'SC D
.S SCH=SCH+1,^TMP("PSO",$J,TR,TD,"SIG",SCH,0)=$P(^PS(52.41,IFN,"SIG",SC,0),"^"),^TMP("PSO",$J,TR,TD,"SIG",0)=SCH
S SC=1,PEN="" F S PEN=$O(^PS(52.41,IFN,2,PEN)) Q:'PEN D
.S MIG=^PS(52.41,IFN,2,PEN,0),^TMP("PSO",$J,TR,TD,"SIO",0)=SC D
..F SCH=1:1:$L(MIG," ") S:$L($G(^TMP("PSO",$J,TR,TD,"SIO",SC,0))_" "_$P(MIG,"",SCH))>80 SC=SC+1,^TMP("PSO",$J,TR,TD,"SIO",0)=SC D
...S ^TMP("PSO",$J,TR,TD,"SIO",SC,0)=$G(^TMP("PSO",$J,TR,TD,"SIO",SC,0))_" "_$P(MIG," ",SCH)
Q
SIG ;
N Z0,Z1,PSOX1,PSOX2 F Z0=1:1:$L(X," ") Q:Z0="" S Z1=$P(X," ",Z0) D
.D:$D(X)&($G(Z1)]"")
..S Y=$O(^PS(51,"B",Z1,0)) Q:'Y!($P($G(^PS(51,+Y,0)),"^",4)>1) S Z1=$P(^PS(51,Y,0),"^",2) Q:'$D(^(9)) S Y=$P(X," ",Z0-1),Y=$E(Y,$L(Y)) S:Y>1 Z1=^(9)
.I $G(^TMP("PSO",$J,TR,TD,"SIG",1,0))']"" S ^TMP("PSO",$J,TR,TD,"SIG",1,0)=Z1,^TMP("PSO",$J,TR,TD,"SIG",0)=1 Q
.F PSOX1=0:0 S PSOX1=$O(^TMP("PSO",$J,TR,TD,"SIG",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1
.I $L(^TMP("PSO",$J,TR,TD,"SIG",PSOX2,0))+$L(Z1)<245 S ^TMP("PSO",$J,TR,TD,"SIG",PSOX2,0)=^TMP("PSO",$J,TR,TD,"SIG",PSOX2,0)_" "_Z1
.E S PSOX2=PSOX2+1,^TMP("PSO",$J,TR,TD,"SIG",PSOX2,0)=Z1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOMHV1 9465 printed Apr 09, 2024@21:39:15 Page 2
PSOMHV1 ;BIR/MHA - MHV API, Build patient medication ; 4/20/05 8:54am
+1 ;;7.0;OUTPATIENT PHARMACY;**204**;DEC 1997
+2 ;External reference ^PS(55 supported by DBIA 2228
+3 ;External reference ^PSDRUG( supported by DBIA 221
+4 ;External reference to ^PS(51 supported by DBIA 2224
+5 ;External reference to ^PS(51.2 supported by DBIA 2226
+6 ;External reference to ^PS(50.7 supported by DBIA 2223
+7 ;External reference to ^PS(50.606 supported by DBIA 2174
+8 ; Input variables: dfn, start date, cut off date
EN(DFN,BDT,EDT) ;entry point to return medication list
+1 if '$GET(DFN)
QUIT
+2 NEW DRG,DRGN,EXD,I,IFN,MIG,LSTFD,ORD,PEN,PSOBD,PSOED,PSODD,PSOOI,PSOSD,RX,RX0,RX2,RX3,TFN,TD,TR,TRM,SC,SCH,ST0,STA,PSODIV
+3 IF '$GET(DT)
SET DT=$$DT^XLFDT
+4 KILL ^TMP("PSO",$JOB)
SET PSOBD=$GET(BDT)
SET PSOED=$GET(EDT)
+5 IF +$GET(PSOBD)<1
SET X1=DT
SET X2=-120
DO C^%DTC
SET PSOBD=X
+6 SET EXD=PSOBD-1
+7 IF PSOED=""
SET PSOED=9999999
+8 FOR
SET EXD=$ORDER(^PS(55,DFN,"P","A",EXD))
if 'EXD
QUIT
if EXD>PSOED
QUIT
Begin DoDot:1
+9 SET RX=0
FOR
SET RX=$ORDER(^PS(55,DFN,"P","A",EXD,RX))
if 'RX
QUIT
if $DATA(^PSRX(RX,0))
DO GET
End DoDot:1
+10 SET STA="ACT^NVR^REF^HLD^NVR^SUS^^^^^^EXP^DCD^DEL^DCD^DCD^HLD"
+11 SET DRG=""
FOR
SET DRG=$ORDER(PSOSD(DRG))
if DRG=""
QUIT
if $GET(PSOSD(DRG))]""
Begin DoDot:1
+12 SET PSOSD($PIECE(STA,"^",$PIECE(PSOSD(DRG),"^",2)+1),DRG)=PSOSD(DRG)
KILL PSOSD(DRG)
End DoDot:1
+13 DO PEN
if $DATA(PSOSD)
DO BLD
+14 QUIT
EN2(DFN,RXLIST) ;Entry point to return data for specified RX #s
+1 if DFN<1
QUIT
+2 if 'RXLIST
QUIT
+3 NEW DRG,DRGN,EXD,I,IFN,MIG,LSTFD,ORD,PEN,PSOBD,PSOED,PSODD,PSOOI,PSOSD,RX,RX0,RX2,RX3,TFN,TD,TR,TRM,SC,SCH,ST0,STA,PSORX,J,PSOERR,RX,PSRXD,PSODIV,PSOSTA
+4 IF '$GET(DT)
SET DT=$$DT^XLFDT
+5 KILL ^TMP("PSO",$JOB)
+6 SET PSOSTA="ACT^NVR^REF^HLD^NVR^SUS^^^^^^EXP^DCD^DEL^DCD^DCD^HLD"
+7 FOR J=1:1
SET PSORX=$PIECE(RXLIST,"^",J)
if PSORX=""
QUIT
Begin DoDot:1
+8 IF '$DATA(^PSRX("B",PSORX))
QUIT
+9 IF $ORDER(^PSRX("B",PSORX,""))=""
QUIT
+10 SET RX=$ORDER(^PSRX("B",PSORX,""))
SET PSRXD=$GET(^PSRX(RX,0))
+11 if PSRXD=""
QUIT
+12 if $PIECE(PSRXD,"^",2)'=DFN
QUIT
+13 if $PIECE($GET(^PSRX(RX,"STA")),"^")=13
QUIT
+14 if $PIECE($GET(^PSRX(RX,"STA")),"^")=15
QUIT
+15 if '$DATA(^PSDRUG($PIECE(PSRXD,"^",6),0))
QUIT
+16 SET IFN=RX
SET TR=$PIECE(PSOSTA,"^",$PIECE($GET(^PSRX(RX,"STA")),"^")+1)
+17 SET TD=$PIECE(^PSDRUG($PIECE(PSRXD,"^",6),0),"^")
+18 DO RXD
+19 QUIT
End DoDot:1
+20 QUIT
+21 ;
EN3(DFN,BDT,EDT) ;entry point to return prescription history
+1 if '$GET(DFN)
QUIT
+2 NEW DRG,DRGN,EXD,I,IFN,MIG,LSTFD,ORD,PEN,PSOBD,PSOED,PSODD,PSOOI,PSOSD,RX,RX0,RX2,RX3,TFN,TD,TR,TRM,SC,SCH,ST0,STA,PSODIV
+3 IF '$GET(DT)
SET DT=$$DT^XLFDT
+4 KILL ^TMP("PSO",$JOB)
SET PSOBD=$GET(BDT)
SET PSOED=$GET(EDT)
+5 IF +$GET(PSOBD)<1
SET X1=DT
SET X2=-120
DO C^%DTC
SET PSOBD=X
+6 SET EXD=PSOBD-1
+7 IF PSOED=""
SET PSOED=9999999
+8 FOR
SET EXD=$ORDER(^PS(55,DFN,"P","A",EXD))
if 'EXD
QUIT
if EXD>PSOED
QUIT
Begin DoDot:1
+9 SET RX=0
FOR
SET RX=$ORDER(^PS(55,DFN,"P","A",EXD,RX))
if 'RX
QUIT
if $DATA(^PSRX(RX,0))
DO GET1
End DoDot:1
+10 SET STA="ACT^NVR^REF^HLD^NVR^SUS^^^^^^EXP^DCD^DEL^DCD^DCD^HLD"
+11 ; Uses RX (Rx IEN) instead of DRUG as a subscript in PSOSD and thus
+12 ; in ^TMP("PSO",$J). Other entry points use DRUG
+13 SET RX=""
FOR
SET RX=$ORDER(PSOSD(RX))
if RX=""
QUIT
if $GET(PSOSD(RX))]""
Begin DoDot:1
+14 SET PSOSD($PIECE(STA,"^",$PIECE(PSOSD(RX),"^",2)+1),RX)=PSOSD(RX)
KILL PSOSD(RX)
End DoDot:1
+15 if $DATA(PSOSD)
DO BLD
+16 QUIT
+17 ;
PEN FOR PEN=0:0
SET PEN=$ORDER(^PS(52.41,"P",DFN,PEN))
if 'PEN
QUIT
Begin DoDot:1
+1 SET ORD=^PS(52.41,PEN,0)
if $PIECE(ORD,"^",2)'=DFN
QUIT
SET DRG=""
+2 if $PIECE(ORD,"^",3)="DC"!($PIECE(ORD,"^",3)="DE")!($PIECE(ORD,"^",3)="")!($PIECE(ORD,"^",3)="RF")
QUIT
+3 SET PSOOI=$PIECE(ORD,"^",8)
SET PSODD=+$PIECE(ORD,"^",9)
+4 SET DRG=$SELECT(PSODD:$PIECE($GET(^PSDRUG(PSODD,0)),"^"),+PSOOI&('PSODD):$PIECE(^PS(50.7,+PSOOI,0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^PS(50.7,+PSOOI,0),"^",2),0),"^"),1:"")
+5 if DRG']""
QUIT
+6 IF $DATA(PSOSD("PEN",DRG))
SET DRG=DRG_"^"_PEN
+7 SET PSOSD("PEN",DRG)=PEN
End DoDot:1
+8 QUIT
GET ;
+1 if $PIECE($GET(^PSRX(RX,"STA")),"^")=13
QUIT
+2 if $PIECE($GET(^PSRX(RX,"STA")),"^")=15
QUIT
+3 if '$PIECE(^PSRX(RX,0),"^",2)
QUIT
+4 if $PIECE(^PSRX(RX,0),"^",2)'=DFN
QUIT
+5 SET RX0=^PSRX(RX,0)
SET RX2=^PSRX(RX,2)
+6 SET DRG=$PIECE(^PSRX(RX,0),"^",6)
SET STA=+^("STA")
if '$DATA(^PSDRUG(DRG,0))
QUIT
+7 SET DRGN=$PIECE(^PSDRUG(DRG,0),"^")
SET ST0=$SELECT(STA<12&($PIECE(RX2,"^",6)<DT):11,1:STA)
+8 IF $DATA(PSOSD(DRGN))
IF ST0>10
if $PIECE(PSOSD(DRGN),"^",2)<11
QUIT
if $PIECE(PSOSD(DRGN),"^",2)>10&($PIECE(RX0,"^",13)<$PIECE(^PSRX(+$PIECE(PSOSD(DRGN),"^"),0),"^",13))
QUIT
+9 IF $DATA(PSOSD(DRGN))
IF $PIECE(PSOSD(DRGN),"^",2)<10
IF ST0<10
SET PSOSD(DRGN_"^"_RX)=RX_"^"_ST0
+10 IF '$TEST
SET PSOSD(DRGN)=RX_"^"_ST0
+11 QUIT
GET1 ;
+1 if '$PIECE(^PSRX(RX,0),"^",2)
QUIT
+2 if $PIECE(^PSRX(RX,0),"^",2)'=DFN
QUIT
+3 SET RX0=^PSRX(RX,0)
SET RX2=^PSRX(RX,2)
+4 SET DRG=$PIECE(^PSRX(RX,0),"^",6)
SET STA=+^("STA")
if '$DATA(^PSDRUG(DRG,0))
QUIT
+5 SET DRGN=$PIECE(^PSDRUG(DRG,0),"^")
SET ST0=$SELECT(STA<12&($PIECE(RX2,"^",6)<DT):11,1:STA)
+6 SET PSOSD(RX)=RX_"^"_ST0
+7 QUIT
BLD ;
+1 SET TR=""
FOR
SET TR=$ORDER(PSOSD(TR))
if TR=""
QUIT
Begin DoDot:1
+2 SET TFN=0
SET TD=""
FOR
SET TD=$ORDER(PSOSD(TR,TD))
if TD=""
QUIT
SET IFN=+PSOSD(TR,TD)
DO @$SELECT(TR="PEN":"PND",1:"RXD")
End DoDot:1
+3 QUIT
RXD ;
+1 if '$DATA(^PSRX(IFN,0))
QUIT
+2 SET RX0=^PSRX(IFN,0)
SET RX2=$GET(^(2))
SET RX3=$GET(^(3))
SET STA=+$GET(^("STA"))
SET TRM=0
SET LSTFD=$PIECE(RX2,"^",2)
+3 SET ^TMP("PSO",$JOB,TR,TD,"RXN",0)=$PIECE(RX0,"^")_"^"_$EXTRACT($PIECE(RX2,"^",13),1,7)_"^"_$SELECT($PIECE(RX0,"^",11)="W":"W",1:"M")_"^"_$PIECE(RX3,"^",7)
+4 SET ^TMP("PSO",$JOB,TR,TD,"RXN",0)=^TMP("PSO",$JOB,TR,TD,"RXN",0)_"^"_$SELECT($PIECE($GET(^PSRX(IFN,"OR1")),"^",5):$PIECE(^PSRX(IFN,"OR1"),"^",5),1:"")_"^"_$EXTRACT($PIECE(RX2,"^",2),1,7)_"^"_$EXTRACT($PIECE(RX2,"^",13),1,7)_"^^"_IFN
+5 SET I=0
FOR
SET I=$ORDER(^PSRX(IFN,1,I))
if 'I
QUIT
SET TRM=TRM+1
SET LSTFD=$PIECE(^PSRX(IFN,1,I,0),"^")
Begin DoDot:1
+6 SET ^TMP("PSO",$JOB,TR,TD,"REF",I,0)=$PIECE(^PSRX(IFN,1,I,0),"^")_"^"_$PIECE(^(0),"^",10)_"^"_$PIECE(^(0),"^",4)_"^"_$EXTRACT($PIECE(^(0),"^",18),1,7)_"^"_$SELECT($PIECE(^(0),"^",2)="W":"W",1:"M")_"^"_$PIECE(^(0),"^",3)
+7 IF $PIECE(^PSRX(IFN,1,I,0),"^",18)
SET $PIECE(^TMP("PSO",$JOB,TR,TD,"RXN",0),"^",2)=$EXTRACT($PIECE(^PSRX(IFN,1,I,0),"^",18),1,7)
+8 SET ^TMP("PSO",$JOB,TR,TD,"REF",0)=$GET(^TMP("PSO",$JOB,TR,TD,"REF",0))+1
End DoDot:1
+9 SET I=0
FOR
SET I=$ORDER(^PSRX(IFN,"P",I))
if 'I
QUIT
Begin DoDot:1
+10 SET ^TMP("PSO",$JOB,TR,TD,"PAR",I,0)=$PIECE(^PSRX(IFN,"P",I,0),"^")_"^"_$PIECE(^(0),"^",10)_"^"_$PIECE(^(0),"^",4)_"^"_$EXTRACT($PIECE(^(0),"^",19),1,7)_"^"_$SELECT($PIECE(^(0),"^",2)="W":"W",1:"M")_"^"_$PIECE(^(0),"^",3)
+11 SET ^TMP("PSO",$JOB,TR,TD,"PAR",0)=$GET(^TMP("PSO",$JOB,TR,TD,"PAR",0))+1
End DoDot:1
+12 SET ^TMP("PSO",$JOB,TR,TD,0)=$PIECE($GET(^PSDRUG(+$PIECE(RX0,"^",6),0)),"^")_"^^"_$PIECE(RX2,"^",6)
+13 SET ^TMP("PSO",$JOB,TR,TD,"P",0)=$PIECE(RX0,"^",4)_"^"_$PIECE($GET(^VA(200,+$PIECE(RX0,"^",4),0)),"^")
+14 SET ST0=$SELECT(STA<12&($PIECE(RX2,"^",6)<DT):11,1:STA)
+15 SET SC=$PIECE("ERROR^ACTIVE^NON-VERIFIED^REFILL FILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^DONE^EXPIRED^DISCONTINUED^DELETED^DISCONTINUED^DISCONTINUED (EDIT)^HOLD^","^",ST0+2)
+16 SET ^TMP("PSO",$JOB,TR,TD,0)=^TMP("PSO",$JOB,TR,TD,0)_"^"_($PIECE(RX0,"^",9)-TRM)_"^"_$PIECE(RX0,"^",13)_"^"_SC_"^"_$PIECE(RX0,"^",8)_"^"_$PIECE(RX0,"^",7)_"^^^"_$PIECE($GET(^PSRX(IFN,"OR1")),"^",2)_"^"_LSTFD_"^^"
+17 SET ^TMP("PSO",$JOB,TR,TD,"DD",0)=1
SET ^TMP("PSO",$JOB,TR,TD,"DD",1,0)=$PIECE(RX0,"^",6)_"^^"
+18 SET (SCH,SC)=0
+19 FOR
SET SC=$ORDER(^PSRX(IFN,"SCH",SC))
if 'SC
QUIT
SET SCH=SCH+1
SET ^TMP("PSO",$JOB,TR,TD,"SCH",SCH,0)=$PIECE(^PSRX(IFN,"SCH",SC,0),"^")
Begin DoDot:1
+20 SET ^TMP("PSO",$JOB,TR,TD,"SCH",0)=$GET(^TMP("PSO",$JOB,TR,TD,"SCH",0))+1
End DoDot:1
+21 DO MDR
+22 SET SC=0
IF $DATA(^PSRX(IFN,"SIG"))
IF '$PIECE(^PSRX(IFN,"SIG"),"^",2)
SET SC=1
SET X=$PIECE(^PSRX(IFN,"SIG"),"^")
DO SIG
+23 IF '$GET(SC)
SET SCH=1
Begin DoDot:1
+24 SET ^TMP("PSO",$JOB,TR,TD,"SIG",SCH,0)=$GET(^PSRX(IFN,"SIG1",1,0))
SET ^TMP("PSO",$JOB,TR,TD,"SIG",0)=SCH
+25 FOR I=1:0
SET I=$ORDER(^PSRX(IFN,"SIG1",I))
if 'I
QUIT
SET SCH=SCH+1
SET ^TMP("PSO",$JOB,TR,TD,"SIG",SCH,0)=^PSRX(IFN,"SIG1",I,0)
SET ^TMP("PSO",$JOB,TR,TD,"SIG",0)=SCH
End DoDot:1
+26 SET (I,SC)=0
+27 FOR
SET I=$ORDER(^PSRX(IFN,"PRC",I))
if 'I
QUIT
SET SC=SC+1
Begin DoDot:1
+28 SET ^TMP("PSO",$JOB,TR,TD,"PC",SC,0)=^PSRX(IFN,"PRC",I,0)
SET ^TMP("PSO",$JOB,TR,TD,"PC",0)=SC
End DoDot:1
+29 SET PSODIV=$PIECE(RX2,"^",9)
+30 IF PSODIV'=""
IF $DATA(^PS(59,PSODIV,0))
SET ^TMP("PSO",$JOB,TR,TD,"DIV",0)=PSODIV_"^"_^PS(59,PSODIV,0)
+31 QUIT
MDR ;
+1 SET (SCH,SC)=0
+2 FOR
SET SC=$ORDER(^PSRX(IFN,"MEDR",SC))
if 'SC
QUIT
Begin DoDot:1
+3 if '$DATA(^PS(51.2,+^PSRX(IFN,"MEDR",SC,0),0))
QUIT
SET SCH=SCH+1
+4 SET ^TMP("PSO",$JOB,TR,TD,"MDR",SCH,0)=$SELECT($PIECE(^PS(51.2,+^PSRX(IFN,"MEDR",SC,0),0),"^",3)]"":$PIECE(^(0),"^",3),1:$PIECE(^(0),"^"))
+5 SET ^TMP("PSO",$JOB,TR,TD,"MDR",0)=SCH
End DoDot:1
+6 QUIT
PND if '$DATA(^PS(52.41,IFN,0))
QUIT
+1 SET ORD=^PS(52.41,IFN,0)
if $PIECE(ORD,"^",2)'=DFN
QUIT
+2 if $PIECE(ORD,"^",3)="DC"!($PIECE(ORD,"^",3)="DE")
QUIT
+3 SET PSOOI=+$PIECE(ORD,"^",8)
SET PSODD=+$PIECE(ORD,"^",9)
+4 SET DRG=$SELECT(PSODD:$PIECE($GET(^PSDRUG(PSODD,0)),"^"),1:$PIECE(^PS(50.7,PSOOI,0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^PS(50.7,PSOOI,0),"^",2),0),"^"))
+5 SET ^TMP("PSO",$JOB,TR,TD,0)=DRG
+6 if PSODD
SET ^TMP("PSO",$JOB,TR,TD,"DD",0)=1
SET ^TMP("PSO",$JOB,TR,TD,"DD",1,0)=PSODD_"^^"
+7 SET ^TMP("PSO",$JOB,TR,TD,0)=^TMP("PSO",$JOB,TR,TD,0)_"^"_$SELECT($GET(^PS(51.2,+$PIECE(ORD,"^",15),0))]"":$PIECE(^PS(51.2,+$PIECE(ORD,"^",15),0),"^",3),1:"")
+8 SET ^TMP("PSO",$JOB,TR,TD,0)=^TMP("PSO",$JOB,TR,TD,0)_"^^"_$PIECE(ORD,"^",11)_"^"_$PIECE($PIECE(ORD,"^",6),".")_"^"_$SELECT($PIECE(ORD,"^",3)'="HD":"PENDING",1:" ONHOLD")_"^^"_$PIECE(ORD,"^",10)
+9 SET $PIECE(^TMP("PSO",$JOB,TR,TD,0),"^",11)=$PIECE(ORD,"^")
+10 SET (SC,SCH)=0
FOR
SET SC=$ORDER(^PS(52.41,IFN,1,SC))
if 'SC
QUIT
Begin DoDot:1
+11 SET SCH=SCH+1
SET ^TMP("PSO",$JOB,TR,TD,"SCH",SCH,0)=$PIECE(^PS(52.41,IFN,1,SC,1),"^")
SET ^TMP("PSO",$JOB,TR,TD,"SCH",0)=SCH
End DoDot:1
+12 SET (SC,SCH)=0
FOR
SET SC=$ORDER(^PS(52.41,IFN,"SIG",SC))
if 'SC
QUIT
Begin DoDot:1
+13 SET SCH=SCH+1
SET ^TMP("PSO",$JOB,TR,TD,"SIG",SCH,0)=$PIECE(^PS(52.41,IFN,"SIG",SC,0),"^")
SET ^TMP("PSO",$JOB,TR,TD,"SIG",0)=SCH
End DoDot:1
+14 SET SC=1
SET PEN=""
FOR
SET PEN=$ORDER(^PS(52.41,IFN,2,PEN))
if 'PEN
QUIT
Begin DoDot:1
+15 SET MIG=^PS(52.41,IFN,2,PEN,0)
SET ^TMP("PSO",$JOB,TR,TD,"SIO",0)=SC
Begin DoDot:2
+16 FOR SCH=1:1:$LENGTH(MIG," ")
if $LENGTH($GET(^TMP("PSO",$JOB,TR,TD,"SIO",SC,0))_" "_$PIECE(MIG,"",SCH))>80
SET SC=SC+1
SET ^TMP("PSO",$JOB,TR,TD,"SIO",0)=SC
Begin DoDot:3
+17 SET ^TMP("PSO",$JOB,TR,TD,"SIO",SC,0)=$GET(^TMP("PSO",$JOB,TR,TD,"SIO",SC,0))_" "_$PIECE(MIG," ",SCH)
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
SIG ;
+1 NEW Z0,Z1,PSOX1,PSOX2
FOR Z0=1:1:$LENGTH(X," ")
if Z0=""
QUIT
SET Z1=$PIECE(X," ",Z0)
Begin DoDot:1
+2 if $DATA(X)&($GET(Z1)]"")
Begin DoDot:2
+3 SET Y=$ORDER(^PS(51,"B",Z1,0))
if 'Y!($PIECE($GET(^PS(51,+Y,0)),"^",4)>1)
QUIT
SET Z1=$PIECE(^PS(51,Y,0),"^",2)
if '$DATA(^(9))
QUIT
SET Y=$PIECE(X," ",Z0-1)
SET Y=$EXTRACT(Y,$LENGTH(Y))
if Y>1
SET Z1=^(9)
End DoDot:2
+4 IF $GET(^TMP("PSO",$JOB,TR,TD,"SIG",1,0))']""
SET ^TMP("PSO",$JOB,TR,TD,"SIG",1,0)=Z1
SET ^TMP("PSO",$JOB,TR,TD,"SIG",0)=1
QUIT
+5 FOR PSOX1=0:0
SET PSOX1=$ORDER(^TMP("PSO",$JOB,TR,TD,"SIG",PSOX1))
if 'PSOX1
QUIT
SET PSOX2=PSOX1
+6 IF $LENGTH(^TMP("PSO",$JOB,TR,TD,"SIG",PSOX2,0))+$LENGTH(Z1)<245
SET ^TMP("PSO",$JOB,TR,TD,"SIG",PSOX2,0)=^TMP("PSO",$JOB,TR,TD,"SIG",PSOX2,0)_" "_Z1
+7 IF '$TEST
SET PSOX2=PSOX2+1
SET ^TMP("PSO",$JOB,TR,TD,"SIG",PSOX2,0)=Z1
End DoDot:1
+8 QUIT
