PSOORRL ;BHAM ISC/SAB - returns patient's outpatient meds ;29-May-2012 15:01;PLS
;;7.0;OUTPATIENT PHARMACY;**4,20,9,34,54,82,124,132,1005,1009,159,214,225,1015**;DEC 1997;Build 62
;External reference to ^PS(55 supported by DBIA 2228
;External reference to ^PSDRUG supported by DBIA 221
;External reference to ^VA(200 supported by DBIA 10060
;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
;External reference to OCL^PSJORRE supported by DBIA 2383
;External reference to OEL^PSJORRE1 supported by DBIA 2384
;Modified - IHS/MSC/DKM - 09/06/06 - Line NVA+3 (3 lines added)
; IHS/MSC/PLS - 08/06/10 - Line TMPBLD+4
OCL(DFN,BDT,EDT,VIEW) ;entry point to return condensed list
; VIEW=0 - This returns the list as it was returned prior to GUI 27
; VIEW=1 - This returns the list in original view GUI 27
; VIEW=2 - This is the new sort with GUI 27
; VIEW=3 - New sort by Sort by Drug Name/status with GUI 27
D @$S($G(VIEW)=3:"OCL^PSOORRL3",$G(VIEW)=1:"OCL^PSOORRLO",$G(VIEW)=2:"OCL^PSOORRLN",1:"ST")
Q
;BHW;PSO*7*159;New SD* Variables
ST N SD,SDT,SDT1
D:$P($G(^PS(55,DFN,0)),"^",6)'=2 EN^PSOHLUP(DFN)
K ^TMP("PS",$J) S TFN=0,PSBDT=$G(BDT),PSEDT=$G(EDT) I +$G(PSBDT)<1 S X1=DT,X2=-120 D C^%DTC S PSBDT=X
S EXDT=PSBDT-1,IFN=0
F S EXDT=$O(^PS(55,DFN,"P","A",EXDT)) Q:'EXDT F S IFN=$O(^PS(55,DFN,"P","A",EXDT,IFN)) Q:'IFN D:$D(^PSRX(IFN,0))
.Q:$P($G(^PSRX(IFN,"STA")),"^")=13
.S TFN=TFN+1,RX0=^PSRX(IFN,0),RX2=$G(^(2)),RX3=$G(^(3)),STA=+$G(^("STA")),TRM=0,LSTFD=$P(RX2,"^",2),LSTRD=$P(RX2,"^",13),LSTDS=$P(RX0,"^",8)
.F I=0:0 S I=$O(^PSRX(IFN,1,I)) Q:'I S TRM=TRM+1,LSTFD=$P(^PSRX(IFN,1,I,0),"^"),LSTDS=$P(^(0),"^",10) S:$P(^(0),"^",18)]"" LSTRD=$P(^(0),"^",18)
.S ^TMP("PS",$J,TFN,0)=IFN_"R;O"_"^"_$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^")_"^^"_$P(RX2,"^",6)_"^"_($P(RX0,"^",9)-TRM)_"^^^"_$P($G(^PSRX(IFN,"OR1")),"^",2)
.S ^TMP("PS",$J,TFN,"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 ST=$P("ERROR^ACTIVE^NON-VERIFIED^REFILL FILL^HOLD^NON-VERIFIED^ACTIVE/SUSP^^^^^DONE^EXPIRED^DISCONTINUED^DISCONTINUED^DISCONTINUED^DISCONTINUED (EDIT)^HOLD^","^",ST0+2)
.S ^TMP("PS",$J,TFN,0)=^TMP("PS",$J,TFN,0)_"^"_ST_"^"_LSTFD_"^"_$P(RX0,"^",8)_"^"_$P(RX0,"^",7)_"^^^"_$P(RX0,"^",13)_"^"_LSTRD_"^"_LSTDS
.S ^TMP("PS",$J,TFN,"SCH",0)=0
.S (SCH,SC)=0 F S SC=$O(^PSRX(IFN,"SCH",SC)) Q:'SC S SCH=SCH+1,^TMP("PS",$J,TFN,"SCH",SCH,0)=$P(^PSRX(IFN,"SCH",SC,0),"^"),^TMP("PS",$J,TFN,"SCH",0)=^TMP("PS",$J,TFN,"SCH",0)+1
.S ^TMP("PS",$J,TFN,"MDR",0)=0,(MDR,MR)=0 F S MR=$O(^PSRX(IFN,"MEDR",MR)) Q:'MR D
..Q:'$D(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0)) S MDR=MDR+1
..I $P($G(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0)),"^",3)]"" S ^TMP("PS",$J,TFN,"MDR",MDR,0)=$P(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0),"^",3)
..I $D(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0)),$P($G(^(0)),"^",3)']"" S ^TMP("PS",$J,TFN,"MDR",MDR,0)=$P(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0),"^")
..S ^TMP("PS",$J,TFN,"MDR",0)=^TMP("PS",$J,TFN,"MDR",0)+1
.S PSOELSE=0 I $D(^PSRX(IFN,"SIG")),'$P(^PSRX(IFN,"SIG"),"^",2) S PSOELSE=1 S X=$P(^PSRX(IFN,"SIG"),"^") D SIG1^PSOORRL1
.I '$G(PSOELSE) S ITFN=1 D
..S ^TMP("PS",$J,TFN,"SIG",ITFN,0)=$G(^PSRX(IFN,"SIG1",1,0)),^TMP("PS",$J,TFN,"SIG",0)=+$G(^TMP("PS",$J,TFN,"SIG",0))+1
..F I=1:0 S I=$O(^PSRX(IFN,"SIG1",I)) Q:'I S ITFN=ITFN+1,^TMP("PS",$J,TFN,"SIG",ITFN,0)=^PSRX(IFN,"SIG1",I,0),^TMP("PS",$J,TFN,"SIG",0)=+$G(^TMP("PS",$J,TFN,"SIG",0))+1
K PSOELSE
S IFN=0 F S IFN=$O(^PS(52.41,"P",DFN,IFN)) Q:'IFN S PSOR=^PS(52.41,IFN,0) D:$P(PSOR,"^",3)="" WAIT D:$P(PSOR,"^",3)'="DC"&($P(PSOR,"^",3)'="DE")&($P(PSOR,"^",3)'="")
.Q:$P(PSOR,"^",3)="RF"
.I $P(PSOR,"^",8)="",$P(PSOR,"^",9)="" D WAIT
.I $P(PSOR,"^",8)="",$P(PSOR,"^",9)="" Q ; QUIT IF STILL NULL AFTER WAITING
.S TFN=TFN+1,^TMP("PS",$J,TFN,0)=IFN_"P;O^"_$S($P(PSOR,"^",9):$P($G(^PSDRUG($P(PSOR,"^",9),0)),"^"),1:$P(^PS(50.7,$P(PSOR,"^",8),0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,$P(PSOR,"^",8),0),"^",2),0),"^"))
.S ^TMP("PS",$J,TFN,0)=^TMP("PS",$J,TFN,0)_"^^^^^^"_$P(PSOR,"^")_"^"_"PENDING^^^"_$P(PSOR,"^",10)_"^"
.S ^TMP("PS",$J,TFN,0)=^TMP("PS",$J,TFN,0)_"^"_$S($P(PSOR,"^",3)="RNW":1,1:0)
.S SD=0 F SCH=0:0 S SCH=$O(^PS(52.41,IFN,1,SCH)) Q:'SCH S SD=SD+1,^TMP("PS",$J,TFN,"SCH",SD,0)=$P(^PS(52.41,IFN,1,SCH,1),"^"),^TMP("PS",$J,TFN,"SCH",0)=SD
.S SD=0 F SCH=0:0 S SCH=$O(^PS(52.41,IFN,"SIG",SCH)) Q:'SCH S SD=SD+1,^TMP("PS",$J,TFN,"SIG",SD,0)=$P(^PS(52.41,IFN,"SIG",SCH,0),"^"),^TMP("PS",$J,TFN,"SIG",0)=SD
.S (IEN,SD)=1,INST=0 F S INST=$O(^PS(52.41,IFN,2,INST)) Q:'INST S (MIG,INST(INST))=^PS(52.41,IFN,2,INST,0),^TMP("PS",$J,TFN,"SIO",0)=SD D
..F SG=1:1:$L(MIG," ") S:$L($G(^TMP("PS",$J,TFN,"SIO",IEN,0))_" "_$P(MIG," ",SG))>80 IEN=IEN+1,SD=SD+1,^TMP("PS",$J,TFN,"SIO",0)=SD S ^TMP("PS",$J,TFN,"SIO",IEN,0)=$G(^TMP("PS",$J,TFN,"SIO",IEN,0))_" "_$P(MIG," ",SG)
D NVA,OCL^PSJORRE(DFN,BDT,EDT,.TFN,+$G(VIEW)),END^PSOORRL1
K SDT,SDT1,EDT,EDT1,BDT,DBT1,X
Q
OEL(DFN,RXNUM) ;returns expanded list on specific order
I $P(RXNUM,";",2)="I" D OEL^PSJORRE1(DFN,$P(RXNUM,";")) Q
D:$P($G(^PS(55,DFN,0)),"^",6)'=2 EN^PSOHLUP(DFN) Q:RXNUM=""
;BHW;PSO*7*159;New SD
N SD
K INST,IFN,^TMP("PS",$J) S FL=$P(RXNUM,";"),IFN=+FL,RXNUM=$P(RXNUM,";",2)
I $G(FL)["P"!($G(FL)["S") D PEN^PSOORRL1 Q
I $G(FL)["N" D NVA^PSOORRL1 Q
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("PS",$J,"RXN",0)=$P(RX0,"^")_"^"_$E($P(RX2,"^",13),1,7)_"^"_$S($P(RX0,"^",11)="W":"W",1:"M")_"^"_$P(RX3,"^",7)_"^"_$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)
D RSTC(0) ;set return to stock node for original
F I=0:0 S I=$O(^PSRX(IFN,1,I)) Q:'I S TRM=TRM+1,LSTFD=$P(^PSRX(IFN,1,I,0),"^") D
.S ^TMP("PS",$J,"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("PS",$J,"RXN",0),"^",2)=$E($P(^PSRX(IFN,1,I,0),"^",18),1,7)
.S ^TMP("PS",$J,"REF",0)=$G(^TMP("PS",$J,"REF",0))+1
.D RSTC(I) ;set return to stock node for refills
F I=0:0 S I=$O(^PSRX(IFN,"P",I)) Q:'I D
.S ^TMP("PS",$J,"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("PS",$J,"PAR",0)=$G(^TMP("PS",$J,"PAR",0))+1
S ^TMP("PS",$J,0)=$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^")_"^^"_$P(RX2,"^",6)
S ^TMP("PS",$J,"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 ST=$P("ERROR^ACTIVE^NON-VERIFIED^REFILL FILL^HOLD^NON-VERIFIED^ACTIVE/SUSP^^^^^DONE^EXPIRED^DISCONTINUE^DISCONTINUED^DISCONTINUED^DISCONTINUED (EDIT)^HOLD^","^",ST0+2)
S ^TMP("PS",$J,0)=^TMP("PS",$J,0)_"^"_($P(RX0,"^",9)-TRM)_"^"_$P(RX0,"^",13)_"^"_ST_"^"_$P(RX0,"^",8)_"^"_$P(RX0,"^",7)_"^^^"_$P($G(^PSRX(IFN,"OR1")),"^",2)_"^"_LSTFD_"^^"
S ^TMP("PS",$J,"DD",0)=1,^TMP("PS",$J,"DD",1,0)=$P(RX0,"^",6)_"^^"
S COD=$S('$G(^PSDRUG(+$P(RX0,"^",6),"I")):1,+$G(^PSDRUG(+$P(RX0,"^",6),"I"))>DT:1,1:0)
S ^TMP("PS",$J,"DD",1,0)=^TMP("PS",$J,"DD",1,0)_$S($P($G(^PSDRUG(+$P(RX0,"^",6),2)),"^",3)["U"&(COD):$P(RX0,"^",6),1:"") K COD
S ^TMP("PS",$J,"SCH",0)=0,(SCH,SC)=0
F S SC=$O(^PSRX(IFN,"SCH",SC)) Q:'SC S SCH=SCH+1,^TMP("PS",$J,"SCH",SCH,0)=$P(^PSRX(IFN,"SCH",SC,0),"^") D
.S ^TMP("PS",$J,"SCH",0)=^TMP("PS",$J,"SCH",0)+1
D MDR^PSOORRL1
S PSOELSE=0 I $D(^PSRX(IFN,"SIG")),'$P(^PSRX(IFN,"SIG"),"^",2) S PSOELSE=1 S X=$P(^PSRX(IFN,"SIG"),"^") D SIG^PSOORRL1
I '$G(PSOELSE) S ITFN=1 D
.S ^TMP("PS",$J,"SIG",ITFN,0)=$G(^PSRX(IFN,"SIG1",1,0)),^TMP("PS",$J,"SIG",0)=+$G(^TMP("PS",$J,"SIG",0))+1
.F I=1:0 S I=$O(^PSRX(IFN,"SIG1",I)) Q:'I S ITFN=ITFN+1,^TMP("PS",$J,"SIG",ITFN,0)=^PSRX(IFN,"SIG1",I,0),^TMP("PS",$J,"SIG",0)=+$G(^TMP("PS",$J,"SIG",0))+1
K PSOELSE
S ^TMP("PS",$J,"PC",0)=0,ITFN=0
F I=0:0 S I=$O(^PSRX(IFN,"PRC",I)) Q:'I S ITFN=ITFN+1,^TMP("PS",$J,"PC",ITFN,0)=^PSRX(IFN,"PRC",I,0),^TMP("PS",$J,"PC",0)=^TMP("PS",$J,"PC",0)+1
Q
;
WAIT ; IF PENDING ENTRY STILL BEING BUILT SEE IF IT COMPLETES WITHIN ANOTHER SECOND
H 1 S PSOR=$G(^PS(52.41,IFN,0))
Q
;
NVA ; Set Non-VA Med Orders in the ^TMP Global
;BHW;PSO*7*159;New SDT,SDT1 Variables
N SDT,SDT1
F I=0:0 S I=$O(^PS(55,DFN,"NVA",I)) Q:'I S X=$G(^PS(55,DFN,"NVA",I,0)) D
.Q:'$P(X,"^")
.S DRG=$S($P(X,"^",2):$P($G(^PSDRUG($P(X,"^",2),0)),"^"),1:$P(^PS(50.7,$P(X,"^"),0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,$P(X,"^"),0),"^",2),0),"^"))
.;IHS/MSC/DKM - 09/06/06 - Next three lines added to support EHR HomeMed functionality.
.I $G(BDT),$P(X,"^",7),$P(X,"^",7)<BDT Q
.D TMPBLD
.Q
.S SDT=$P(X,"^",9) I 'SDT D TMPBLD Q
.I $E(SDT,4,5),$E(SDT,6,7) D
..;I $P(X,"^",9) D Q
..I $G(BDT),SDT<BDT Q
..I $G(EDT),SDT>EDT Q
..I $G(BDT),$P(X,"^",7),$P(X,"^",7)<BDT Q
..D TMPBLD
.I $E(SDT,4,5),'$E(SDT,6,7) D
..S SDT1=$E(SDT,1,5),BDT1=$E(+$G(BDT),1,5),EDT1=$E(+$G(EDT),1,5)
..I $G(BDT1),SDT1<BDT1 Q
..I $G(EDT1),SDT1>EDT1 Q
..I $G(BDT1),$P(X,"^",7),$E($P(X,"^",7),1,5)<BDT1 Q
..D TMPBLD
.I '$E(SDT,4,5),'$E($P(X,"^",9),6,7) D
..;I $P(X,"^",9) D Q
..S SDT1=$E(SDT,1,3),BDT1=$E(+$G(BDT),1,3),EDT1=$E(+$G(EDT),1,3)
..I $G(BDT1),SDT1<BDT1 Q
..I $G(EDT1),SDT1>EDT1 Q
..I $G(BDT1),$P(X,"^",7),$E($P(X,"^",7),1,3)<BDT1 Q
..D TMPBLD
Q
TMPBLD S TFN=$G(TFN)+1,^TMP("PS",$J,TFN,0)=I_"N;O^"_DRG
S $P(^TMP("PS",$J,TFN,0),"^",8)=$P(X,"^",8)_"^"_$S($P(X,"^",7):"DISCONTINUED",1:"ACTIVE")
S ^TMP("PS",$J,TFN,"SCH",0)=1,^TMP("PS",$J,TFN,"SCH",1,0)=$P(X,"^",5)
S ^TMP("PS",$J,TFN,"SIG",0)=1,^TMP("PS",$J,TFN,"SIG",1,0)=$P(X,"^",3)_" "_$P(X,"^",4)_" "_$P(X,"^",5)
;IHS/MSC/REC/PLS - 08/06/2010 - Add Med Rec information
I $D(^PS(55,DFN,"NVA",I,21400)) D
.N X0
.S X0=$G(^PS(55,DFN,"NVA",I,21400))
.S ^TMP("PS",$J,TFN,"MREC",0)=1
.S ^TMP("PS",$J,TFN,"MREC",1,0)=$$FMTE^XLFDT($P(X0,U),1)_U_$P(X0,U,2)_U_$P(X0,U,3)
.N LP
.S LP=0 F S LP=$O(^PS(55,DFN,"NVA",I,21401,LP)) Q:'LP D
..S ^TMP("PS",$J,TFN,"MREC",1,LP)=$G(^PS(55,"NVA",I,21401,LP,0))
Q
RSTC(REF) ; return to stock
F J=0:0 S J=$O(^PSRX(IFN,"A",J)) Q:'J S II=$G(^(J,0)) I $P(II,"^",2)="I",$P(II,"^",4)=REF D
.I REF=0,'$$RXRLDT^PSOBPSUT(IFN,0) S ^TMP("PS",$J,"RXN","RSTC")=$P(II,"^")_"^"_$P(II,"^",3)_"^"_$P(II,"^",5) Q
.I REF>0,'$$RXRLDT^PSOBPSUT(IFN,REF) S ^TMP("PS",$J,"REF",REF,"RSTC")=$P(II,"^")_"^"_$P(II,"^",3)_"^"_$P(II,"^",5)
Q
PSOORRL ;BHAM ISC/SAB - returns patient's outpatient meds ;29-May-2012 15:01;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**4,20,9,34,54,82,124,132,1005,1009,159,214,225,1015**;DEC 1997;Build 62
+2 ;External reference to ^PS(55 supported by DBIA 2228
+3 ;External reference to ^PSDRUG supported by DBIA 221
+4 ;External reference to ^VA(200 supported by DBIA 10060
+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 ;External reference to OCL^PSJORRE supported by DBIA 2383
+9 ;External reference to OEL^PSJORRE1 supported by DBIA 2384
+10 ;Modified - IHS/MSC/DKM - 09/06/06 - Line NVA+3 (3 lines added)
+11 ; IHS/MSC/PLS - 08/06/10 - Line TMPBLD+4
OCL(DFN,BDT,EDT,VIEW) ;entry point to return condensed list
+1 ; VIEW=0 - This returns the list as it was returned prior to GUI 27
+2 ; VIEW=1 - This returns the list in original view GUI 27
+3 ; VIEW=2 - This is the new sort with GUI 27
+4 ; VIEW=3 - New sort by Sort by Drug Name/status with GUI 27
+5 DO @$SELECT($GET(VIEW)=3:"OCL^PSOORRL3",$GET(VIEW)=1:"OCL^PSOORRLO",$GET(VIEW)=2:"OCL^PSOORRLN",1:"ST")
+6 QUIT
+7 ;BHW;PSO*7*159;New SD* Variables
ST NEW SD,SDT,SDT1
+1 IF $PIECE($GET(^PS(55,DFN,0)),"^",6)'=2
DO EN^PSOHLUP(DFN)
+2 KILL ^TMP("PS",$JOB)
SET TFN=0
SET PSBDT=$GET(BDT)
SET PSEDT=$GET(EDT)
IF +$GET(PSBDT)<1
SET X1=DT
SET X2=-120
DO C^%DTC
SET PSBDT=X
+3 SET EXDT=PSBDT-1
SET IFN=0
+4 FOR
SET EXDT=$ORDER(^PS(55,DFN,"P","A",EXDT))
IF 'EXDT
QUIT
FOR
SET IFN=$ORDER(^PS(55,DFN,"P","A",EXDT,IFN))
IF 'IFN
QUIT
IF $DATA(^PSRX(IFN,0))
Begin DoDot:1
+5 IF $PIECE($GET(^PSRX(IFN,"STA")),"^")=13
QUIT
+6 SET TFN=TFN+1
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)
SET LSTRD=$PIECE(RX2,"^",13)
SET LSTDS=$PIECE(RX0,"^",8)
+7 FOR I=0:0
SET I=$ORDER(^PSRX(IFN,1,I))
IF 'I
QUIT
SET TRM=TRM+1
SET LSTFD=$PIECE(^PSRX(IFN,1,I,0),"^")
SET LSTDS=$PIECE(^(0),"^",10)
IF $PIECE(^(0),"^",18)]""
SET LSTRD=$PIECE(^(0),"^",18)
+8 SET ^TMP("PS",$JOB,TFN,0)=IFN_"R;O"_"^"_$PIECE($GET(^PSDRUG(+$PIECE(RX0,"^",6),0)),"^")_"^^"_$PIECE(RX2,"^",6)_"^"_($PIECE(RX0,"^",9)-TRM)_"^^^"_$PIECE($GET(^PSRX(IFN,"OR1")),"^",2)
+9 SET ^TMP("PS",$JOB,TFN,"P",0)=$PIECE(RX0,"^",4)_"^"_$PIECE($GET(^VA(200,+$PIECE(RX0,"^",4),0)),"^")
+10 SET ST0=$SELECT(STA<12&($PIECE(RX2,"^",6)<DT):11,1:STA)
+11 SET ST=$PIECE("ERROR^ACTIVE^NON-VERIFIED^REFILL FILL^HOLD^NON-VERIFIED^ACTIVE/SUSP^^^^^DONE^EXPIRED^DISCONTINUED^DISCONTINUED^DISCONTINUED^DISCONTINUED (EDIT)^HOLD^","^",ST0+2)
+12 SET ^TMP("PS",$JOB,TFN,0)=^TMP("PS",$JOB,TFN,0)_"^"_ST_"^"_LSTFD_"^"_$PIECE(RX0,"^",8)_"^"_$PIECE(RX0,"^",7)_"^^^"_$PIECE(RX0,"^",13)_"^"_LSTRD_"^"_LSTDS
+13 SET ^TMP("PS",$JOB,TFN,"SCH",0)=0
+14 SET (SCH,SC)=0
FOR
SET SC=$ORDER(^PSRX(IFN,"SCH",SC))
IF 'SC
QUIT
SET SCH=SCH+1
SET ^TMP("PS",$JOB,TFN,"SCH",SCH,0)=$PIECE(^PSRX(IFN,"SCH",SC,0),"^")
SET ^TMP("PS",$JOB,TFN,"SCH",0)=^TMP("PS",$JOB,TFN,"SCH",0)+1
+15 SET ^TMP("PS",$JOB,TFN,"MDR",0)=0
SET (MDR,MR)=0
FOR
SET MR=$ORDER(^PSRX(IFN,"MEDR",MR))
IF 'MR
QUIT
Begin DoDot:2
+16 IF '$DATA(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0))
QUIT
SET MDR=MDR+1
+17 IF $PIECE($GET(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0)),"^",3)]""
SET ^TMP("PS",$JOB,TFN,"MDR",MDR,0)=$PIECE(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0),"^",3)
+18 IF $DATA(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0))
IF $PIECE($GET(^(0)),"^",3)']""
SET ^TMP("PS",$JOB,TFN,"MDR",MDR,0)=$PIECE(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0),"^")
+19 SET ^TMP("PS",$JOB,TFN,"MDR",0)=^TMP("PS",$JOB,TFN,"MDR",0)+1
End DoDot:2
+20 SET PSOELSE=0
IF $DATA(^PSRX(IFN,"SIG"))
IF '$PIECE(^PSRX(IFN,"SIG"),"^",2)
SET PSOELSE=1
SET X=$PIECE(^PSRX(IFN,"SIG"),"^")
DO SIG1^PSOORRL1
+21 IF '$GET(PSOELSE)
SET ITFN=1
Begin DoDot:2
+22 SET ^TMP("PS",$JOB,TFN,"SIG",ITFN,0)=$GET(^PSRX(IFN,"SIG1",1,0))
SET ^TMP("PS",$JOB,TFN,"SIG",0)=+$GET(^TMP("PS",$JOB,TFN,"SIG",0))+1
+23 FOR I=1:0
SET I=$ORDER(^PSRX(IFN,"SIG1",I))
IF 'I
QUIT
SET ITFN=ITFN+1
SET ^TMP("PS",$JOB,TFN,"SIG",ITFN,0)=^PSRX(IFN,"SIG1",I,0)
SET ^TMP("PS",$JOB,TFN,"SIG",0)=+$GET(^TMP("PS",$JOB,TFN,"SIG",0))+1
End DoDot:2
End DoDot:1
+24 KILL PSOELSE
+25 SET IFN=0
FOR
SET IFN=$ORDER(^PS(52.41,"P",DFN,IFN))
IF 'IFN
QUIT
SET PSOR=^PS(52.41,IFN,0)
IF $PIECE(PSOR,"^",3)=""
DO WAIT
IF $PIECE(PSOR,"^",3)'="DC"&($PIECE(PSOR,"^",3)'="DE")&($PIECE(PSOR,"^",3)'="")
Begin DoDot:1
+26 IF $PIECE(PSOR,"^",3)="RF"
QUIT
+27 IF $PIECE(PSOR,"^",8)=""
IF $PIECE(PSOR,"^",9)=""
DO WAIT
+28 ; QUIT IF STILL NULL AFTER WAITING
IF $PIECE(PSOR,"^",8)=""
IF $PIECE(PSOR,"^",9)=""
QUIT
+29 SET TFN=TFN+1
SET ^TMP("PS",$JOB,TFN,0)=IFN_"P;O^"_$SELECT($PIECE(PSOR,"^",9):$PIECE($GET(^PSDRUG($PIECE(PSOR,"^",9),0)),"^"),1:$PIECE(^PS(50.7,$PIECE(PSOR,"^",8),0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^PS(50.7,$PIECE(PSOR,"^",8),0),"^",2),0),"^"))
+30 SET ^TMP("PS",$JOB,TFN,0)=^TMP("PS",$JOB,TFN,0)_"^^^^^^"_$PIECE(PSOR,"^")_"^"_"PENDING^^^"_$PIECE(PSOR,"^",10)_"^"
+31 SET ^TMP("PS",$JOB,TFN,0)=^TMP("PS",$JOB,TFN,0)_"^"_$SELECT($PIECE(PSOR,"^",3)="RNW":1,1:0)
+32 SET SD=0
FOR SCH=0:0
SET SCH=$ORDER(^PS(52.41,IFN,1,SCH))
IF 'SCH
QUIT
SET SD=SD+1
SET ^TMP("PS",$JOB,TFN,"SCH",SD,0)=$PIECE(^PS(52.41,IFN,1,SCH,1),"^")
SET ^TMP("PS",$JOB,TFN,"SCH",0)=SD
+33 SET SD=0
FOR SCH=0:0
SET SCH=$ORDER(^PS(52.41,IFN,"SIG",SCH))
IF 'SCH
QUIT
SET SD=SD+1
SET ^TMP("PS",$JOB,TFN,"SIG",SD,0)=$PIECE(^PS(52.41,IFN,"SIG",SCH,0),"^")
SET ^TMP("PS",$JOB,TFN,"SIG",0)=SD
+34 SET (IEN,SD)=1
SET INST=0
FOR
SET INST=$ORDER(^PS(52.41,IFN,2,INST))
IF 'INST
QUIT
SET (MIG,INST(INST))=^PS(52.41,IFN,2,INST,0)
SET ^TMP("PS",$JOB,TFN,"SIO",0)=SD
Begin DoDot:2
+35 FOR SG=1:1:$LENGTH(MIG," ")
IF $LENGTH($GET(^TMP("PS",$JOB,TFN,"SIO",IEN,0))_" "_$PIECE(MIG," ",SG))>80
SET IEN=IEN+1
SET SD=SD+1
SET ^TMP("PS",$JOB,TFN,"SIO",0)=SD
SET ^TMP("PS",$JOB,TFN,"SIO",IEN,0)=$GET(^TMP("PS",$JOB,TFN,"SIO",IEN,0))_" "_$PIECE(MIG," ",SG)
End DoDot:2
End DoDot:1
+36 DO NVA
DO OCL^PSJORRE(DFN,BDT,EDT,.TFN,+$GET(VIEW))
DO END^PSOORRL1
+37 KILL SDT,SDT1,EDT,EDT1,BDT,DBT1,X
+38 QUIT
OEL(DFN,RXNUM) ;returns expanded list on specific order
+1 IF $PIECE(RXNUM,";",2)="I"
DO OEL^PSJORRE1(DFN,$PIECE(RXNUM,";"))
QUIT
+2 IF $PIECE($GET(^PS(55,DFN,0)),"^",6)'=2
DO EN^PSOHLUP(DFN)
IF RXNUM=""
QUIT
+3 ;BHW;PSO*7*159;New SD
+4 NEW SD
+5 KILL INST,IFN,^TMP("PS",$JOB)
SET FL=$PIECE(RXNUM,";")
SET IFN=+FL
SET RXNUM=$PIECE(RXNUM,";",2)
+6 IF $GET(FL)["P"!($GET(FL)["S")
DO PEN^PSOORRL1
QUIT
+7 IF $GET(FL)["N"
DO NVA^PSOORRL1
QUIT
+8 IF '$DATA(^PSRX(IFN,0))
QUIT
+9 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)
+10 SET ^TMP("PS",$JOB,"RXN",0)=$PIECE(RX0,"^")_"^"_$EXTRACT(...
SET $PIECE(RX2,"^",13),1,7)_"^"_$SELECT($PIECE(RX0,"^",11)="W":"W",1:"M")_"^"_$PIECE(RX3,"^",7)_"^"_$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)
+11 ;set return to stock node for original
DO RSTC(0)
+12 FOR I=0:0
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
+13 SET ^TMP("PS",$JOB,"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)
+14 IF $PIECE(^PSRX(IFN,1,I,0),"^",18)
SET $PIECE(^TMP("PS",$JOB,"RXN",0),"^",2)=$EXTRACT($PIECE(^PSRX(IFN,1,I,0),"^",18),1,7)
+15 SET ^TMP("PS",$JOB,"REF",0)=$GET(^TMP("PS",$JOB,"REF",0))+1
+16 ;set return to stock node for refills
DO RSTC(I)
End DoDot:1
+17 FOR I=0:0
SET I=$ORDER(^PSRX(IFN,"P",I))
IF 'I
QUIT
Begin DoDot:1
+18 SET ^TMP("PS",$JOB,"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)
+19 SET ^TMP("PS",$JOB,"PAR",0)=$GET(^TMP("PS",$JOB,"PAR",0))+1
End DoDot:1
+20 SET ^TMP("PS",$JOB,0)=$PIECE($GET(^PSDRUG(+$PIECE(RX0,"^",6),0)),"^")_"^^"_$PIECE(RX2,"^",6)
+21 SET ^TMP("PS",$JOB,"P",0)=$PIECE(RX0,"^",4)_"^"_$PIECE($GET(^VA(200,+$PIECE(RX0,"^",4),0)),"^")
+22 SET ST0=$SELECT(STA<12&($PIECE(RX2,"^",6)<DT):11,1:STA)
+23 SET ST=$PIECE("ERROR^ACTIVE^NON-VERIFIED^REFILL FILL^HOLD^NON-VERIFIED^ACTIVE/SUSP^^^^^DONE^EXPIRED^DISCONTINUE^DISCONTINUED^DISCONTINUED^DISCONTINUED (EDIT)^HOLD^","^",ST0+2)
+24 SET ^TMP("PS",$JOB,0)=^TMP("PS",$JOB,0)_"^"_($PIECE(RX0,"^",9)-TRM)_"^"_$PIECE(RX0,"^",13)_"^"_ST_"^"_$PIECE(RX0,"^",8)_"^"_$PIECE(RX0,"^",7)_"^^^"_$PIECE($GET(^PSRX(IFN,"OR1")),"^",2)_"^"_LSTFD_"^^"
+25 SET ^TMP("PS",$JOB,"DD",0)=1
SET ^TMP("PS",$JOB,"DD",1,0)=$PIECE(RX0,"^",6)_"^^"
+26 SET COD=$SELECT('$GET(^PSDRUG(+$PIECE(RX0,"^",6),"I")):1,+$GET(^PSDRUG(+$PIECE(RX0,"^",6),"I"))>DT:1,1:0)
+27 SET ^TMP("PS",$JOB,"DD",1,0)=^TMP("PS",$JOB,"DD",1,0)_$SELECT($PIECE($GET(^PSDRUG(+$PIECE(RX0,"^",6),2)),"^",3)["U"&(COD):$PIECE(RX0,"^",6),1:"")
KILL COD
+28 SET ^TMP("PS",$JOB,"SCH",0)=0
SET (SCH,SC)=0
+29 FOR
SET SC=$ORDER(^PSRX(IFN,"SCH",SC))
IF 'SC
QUIT
SET SCH=SCH+1
SET ^TMP("PS",$JOB,"SCH",SCH,0)=$PIECE(^PSRX(IFN,"SCH",SC,0),"^")
Begin DoDot:1
+30 SET ^TMP("PS",$JOB,"SCH",0)=^TMP("PS",$JOB,"SCH",0)+1
End DoDot:1
+31 DO MDR^PSOORRL1
+32 SET PSOELSE=0
IF $DATA(^PSRX(IFN,"SIG"))
IF '$PIECE(^PSRX(IFN,"SIG"),"^",2)
SET PSOELSE=1
SET X=$PIECE(^PSRX(IFN,"SIG"),"^")
DO SIG^PSOORRL1
+33 IF '$GET(PSOELSE)
SET ITFN=1
Begin DoDot:1
+34 SET ^TMP("PS",$JOB,"SIG",ITFN,0)=$GET(^PSRX(IFN,"SIG1",1,0))
SET ^TMP("PS",$JOB,"SIG",0)=+$GET(^TMP("PS",$JOB,"SIG",0))+1
+35 FOR I=1:0
SET I=$ORDER(^PSRX(IFN,"SIG1",I))
IF 'I
QUIT
SET ITFN=ITFN+1
SET ^TMP("PS",$JOB,"SIG",ITFN,0)=^PSRX(IFN,"SIG1",I,0)
SET ^TMP("PS",$JOB,"SIG",0)=+$GET(^TMP("PS",$JOB,"SIG",0))+1
End DoDot:1
+36 KILL PSOELSE
+37 SET ^TMP("PS",$JOB,"PC",0)=0
SET ITFN=0
+38 FOR I=0:0
SET I=$ORDER(^PSRX(IFN,"PRC",I))
IF 'I
QUIT
SET ITFN=ITFN+1
SET ^TMP("PS",$JOB,"PC",ITFN,0)=^PSRX(IFN,"PRC",I,0)
SET ^TMP("PS",$JOB,"PC",0)=^TMP("PS",$JOB,"PC",0)+1
+39 QUIT
+40 ;
WAIT ; IF PENDING ENTRY STILL BEING BUILT SEE IF IT COMPLETES WITHIN ANOTHER SECOND
+1 HANG 1
SET PSOR=$GET(^PS(52.41,IFN,0))
+2 QUIT
+3 ;
NVA ; Set Non-VA Med Orders in the ^TMP Global
+1 ;BHW;PSO*7*159;New SDT,SDT1 Variables
+2 NEW SDT,SDT1
+3 FOR I=0:0
SET I=$ORDER(^PS(55,DFN,"NVA",I))
IF 'I
QUIT
SET X=$GET(^PS(55,DFN,"NVA",I,0))
Begin DoDot:1
+4 IF '$PIECE(X,"^")
QUIT
+5 SET DRG=$SELECT($PIECE(X,"^",2):$PIECE($GET(^PSDRUG($PIECE(X,"^",2),0)),"^"),1:$PIECE(^PS(50.7,$PIECE(X,"^"),0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^PS(50.7,$PIECE(X,"^"),0),"^",2),0),"^"))
+6 ;IHS/MSC/DKM - 09/06/06 - Next three lines added to support EHR HomeMed functionality.
+7 IF $GET(BDT)
IF $PIECE(X,"^",7)
IF $PIECE(X,"^",7)<BDT
QUIT
+8 DO TMPBLD
+9 QUIT
+10 SET SDT=$PIECE(X,"^",9)
IF 'SDT
DO TMPBLD
QUIT
+11 IF $EXTRACT(SDT,4,5)
IF $EXTRACT(SDT,6,7)
Begin DoDot:2
+12 ;I $P(X,"^",9) D Q
+13 IF $GET(BDT)
IF SDT<BDT
QUIT
+14 IF $GET(EDT)
IF SDT>EDT
QUIT
+15 IF $GET(BDT)
IF $PIECE(X,"^",7)
IF $PIECE(X,"^",7)<BDT
QUIT
+16 DO TMPBLD
End DoDot:2
+17 IF $EXTRACT(SDT,4,5)
IF '$EXTRACT(SDT,6,7)
Begin DoDot:2
+18 SET SDT1=$EXTRACT(SDT,1,5)
SET BDT1=$EXTRACT(+$GET(BDT),1,5)
SET EDT1=$EXTRACT(+$GET(EDT),1,5)
+19 IF $GET(BDT1)
IF SDT1<BDT1
QUIT
+20 IF $GET(EDT1)
IF SDT1>EDT1
QUIT
+21 IF $GET(BDT1)
IF $PIECE(X,"^",7)
IF $EXTRACT($PIECE(X,"^",7),1,5)<BDT1
QUIT
+22 DO TMPBLD
End DoDot:2
+23 IF '$EXTRACT(SDT,4,5)
IF '$EXTRACT($PIECE(X,"^",9),6,7)
Begin DoDot:2
+24 ;I $P(X,"^",9) D Q
+25 SET SDT1=$EXTRACT(SDT,1,3)
SET BDT1=$EXTRACT(+$GET(BDT),1,3)
SET EDT1=$EXTRACT(+$GET(EDT),1,3)
+26 IF $GET(BDT1)
IF SDT1<BDT1
QUIT
+27 IF $GET(EDT1)
IF SDT1>EDT1
QUIT
+28 IF $GET(BDT1)
IF $PIECE(X,"^",7)
IF $EXTRACT($PIECE(X,"^",7),1,3)<BDT1
QUIT
+29 DO TMPBLD
End DoDot:2
End DoDot:1
+30 QUIT
TMPBLD SET TFN=$GET(TFN)+1
SET ^TMP("PS",$JOB,TFN,0)=I_"N;O^"_DRG
+1 SET $PIECE(^TMP("PS",$JOB,TFN,0),"^",8)=$PIECE(X,"^",8)_"^"_$SELECT($PIECE(X,"^",7):"DISCONTINUED",1:"ACTIVE")
+2 SET ^TMP("PS",$JOB,TFN,"SCH",0)=1
SET ^TMP("PS",$JOB,TFN,"SCH",1,0)=$PIECE(X,"^",5)
+3 SET ^TMP("PS",$JOB,TFN,"SIG",0)=1
SET ^TMP("PS",$JOB,TFN,"SIG",1,0)=$PIECE(X,"^",3)_" "_$PIECE(X,"^",4)_" "_$PIECE(X,"^",5)
+4 ;IHS/MSC/REC/PLS - 08/06/2010 - Add Med Rec information
+5 IF $DATA(^PS(55,DFN,"NVA",I,21400))
Begin DoDot:1
+6 NEW X0
+7 SET X0=$GET(^PS(55,DFN,"NVA",I,21400))
+8 SET ^TMP("PS",$JOB,TFN,"MREC",0)=1
+9 SET ^TMP("PS",$JOB,TFN,"MREC",1,0)=$$FMTE^XLFDT($PIECE(X0,U),1)_U_$PIECE(X0,U,2)_U_$PIECE(X0,U,3)
+10 NEW LP
+11 SET LP=0
FOR
SET LP=$ORDER(^PS(55,DFN,"NVA",I,21401,LP))
IF 'LP
QUIT
Begin DoDot:2
+12 SET ^TMP("PS",$JOB,TFN,"MREC",1,LP)=$GET(^PS(55,"NVA",I,21401,LP,0))
End DoDot:2
End DoDot:1
+13 QUIT
RSTC(REF) ; return to stock
+1 FOR J=0:0
SET J=$ORDER(^PSRX(IFN,"A",J))
IF 'J
QUIT
SET II=$GET(^(J,0))
IF $PIECE(II,"^",2)="I"
IF $PIECE(II,"^",4)=REF
Begin DoDot:1
+2 IF REF=0
IF '$$RXRLDT^PSOBPSUT(IFN,0)
SET ^TMP("PS",$JOB,"RXN","RSTC")=$PIECE(II,"^")_"^"_$PIECE(II,"^",3)_"^"_$PIECE(II,"^",5)
QUIT
+3 IF REF>0
IF '$$RXRLDT^PSOBPSUT(IFN,REF)
SET ^TMP("PS",$JOB,"REF",REF,"RSTC")=$PIECE(II,"^")_"^"_$PIECE(II,"^",3)_"^"_$PIECE(II,"^",5)
End DoDot:1
+4 QUIT
