PSOORRL1 ;BHAM ISC/SAB,TJH - sub-module for PSOORRL ;May 29, 2020@14:36:35
;;7.0;OUTPATIENT PHARMACY;**20,46,132,159,441**;DEC 1997;Build 208
;External reference to ^PS(51.2 supported by DBIA 2226
;External reference to ^PS(50.607 supported by DBIA 2221
;External reference to ^PS(50.606 supported by DBIA 2174
;External reference to ^PS(51 supported by DBIA 2224
;External reference to ^PS(50.7 supported by DBIA 2223
;External reference to ^PSDRUG supported by DBIA 221
;External reference to ^PS(55 supported by DBIA 2228
;
MDR ;
S ^TMP("PS",$J,"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,"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,"MDR",MDR,0)=$P(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0),"^")
.S ^TMP("PS",$J,"MDR",0)=^TMP("PS",$J,"MDR",0)+1
Q
;
PEN ;
;BHW;PSO*7*159;New SD Variable
N SD
Q:'$D(^PS(52.41,IFN,0))!($P($G(^PS(52.41,IFN,0)),"^",3)="RF") S PSOR=^PS(52.41,IFN,0)
S ^TMP("PS",$J,0)=$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),"^"))
I $P(PSOR,"^",9) D
.S ^TMP("PS",$J,"DD",0)=1
.S COD=$S('$G(^PSDRUG($P(PSOR,"^",9),"I")):1,+$G(^PSDRUG($P(PSOR,"^",9),"I"))>DT:1,1:0)
.S ^TMP("PS",$J,"DD",1,0)=$P(PSOR,"^",9)_"^^"_$S($P($G(^PSDRUG($P(PSOR,"^",9),2)),"^",3)["U"&(COD):$P(PSOR,"^",9),1:"") K COD
S ^TMP("PS",$J,0)=^TMP("PS",$J,0)_"^"_$S($G(^PS(51.2,+$P(PSOR,"^",15),0))]"":$P(^PS(51.2,+$P(PSOR,"^",15),0),"^",3),1:"")_"^^"_$P(PSOR,"^",11)_"^"_$P($P(PSOR,"^",6),".")_"^"_$S($P(PSOR,"^",3)'="HD":"PENDING",1:" ON HOLD")_"^^"_$P(PSOR,"^",10)
S $P(^TMP("PS",$J,0),"^",11)=$P(PSOR,"^")
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,"SCH",SD,0)=$P(^PS(52.41,IFN,1,SCH,1),"^"),^TMP("PS",$J,"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,"SIG",SD,0)=$P(^PS(52.41,IFN,"SIG",SCH,0),"^"),^TMP("PS",$J,"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,"SIO",0)=SD D
.F SG=1:1:$L(MIG," ") S:$L($G(^TMP("PS",$J,"SIO",SD,0))_" "_$P(MIG," ",SG))>80 SD=SD+1,^TMP("PS",$J,"SIO",0)=SD S ^TMP("PS",$J,"SIO",SD,0)=$G(^TMP("PS",$J,"SIO",SD,0))_" "_$P(MIG," ",SG)
S:$P($G(^PS(52.41,IFN,4)),U,2)]"" ^TMP("PS",$J,"IND",0)=1,^TMP("PS",$J,"IND",1,0)=$P(^PS(52.41,IFN,4),U,2) ;*441-IND
END K FL,SD,SCH,%T,Y,ST,ST0,PSBDT,PSEDT,IFN,EXDT,RX0,RX2,RX3,TRM,I,X,Z1,Z0,PSOX1,PSOX2,PSOR,STA,TFN,X1,X2,SC,MDR,MR,IFN,MIG,INST
K BDT,EDT,IEN,ITFN,RXNUM
Q
NVA ;non-va meds display
Q:'$D(^PS(55,DFN,"NVA",IFN,0))!('$P($G(^PS(55,DFN,"NVA",IFN,0)),"^"))
S PSOR=^PS(55,DFN,"NVA",IFN,0)
S ^TMP("PS",$J,0)=$S($P(PSOR,"^",2):$P($G(^PSDRUG($P(PSOR,"^",2),0)),"^"),1:$P(^PS(50.7,$P(PSOR,"^"),0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,$P(PSOR,"^"),0),"^",2),0),"^"))
I $P(PSOR,"^",2) D
.S ^TMP("PS",$J,"DD",0)=1
.S COD=$S('$G(^PSDRUG($P(PSOR,"^",2),"I")):1,+$G(^PSDRUG($P(PSOR,"^",2),"I"))>DT:1,1:0)
.S ^TMP("PS",$J,"DD",1,0)=$P(PSOR,"^",2)_"^^"_$S($P($G(^PSDRUG($P(PSOR,"^",2),2)),"^",3)["U"&(COD):$P(PSOR,"^",2),1:"") K COD
S ^TMP("PS",$J,0)=^TMP("PS",$J,0)_"^^^N/A^"_$P($P(PSOR,"^",9),".")_"^"_$S('$P(PSOR,"^",7):"ACTIVE",1:"DISCONTINUED")_"^^N/A^^^"_$P(PSOR,"^",8)
S ^TMP("PS",$J,"SCH",1,0)=$P(PSOR,"^",5),^TMP("PS",$J,"SCH",0)=1
S ^TMP("PS",$J,"SIG",1,0)=$P(PSOR,"^",3)_" "_$P(PSOR,"^",4)_" "_$P(PSOR,"^",5),^TMP("PS",$J,"SIG",0)=1
S ^TMP("PS",$J,"SIO",1,0)=$P(PSOR,"^",3)_" "_$P(PSOR,"^",4)_" "_$P(PSOR,"^",5),^TMP("PS",$J,"SIO",0)=1
K PSOR
S:$P($G(^PS(55,DFN,"NVA",IFN,2)),U)]"" ^TMP("PS",$J,"IND",0)=1,^TMP("PS",$J,"IND",1,0)=$P($G(^PS(55,DFN,"NVA",IFN,2)),U) ;*441-IND
Q
;
SIG ;expands SIG expanded list
F Z0=1:1:$L(X," ") G:Z0="" EN 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("PS",$J,"SIG",1,0))']"" S ^TMP("PS",$J,"SIG",1,0)=Z1,^TMP("PS",$J,"SIG",0)=1 Q
.F PSOX1=0:0 S PSOX1=$O(^TMP("PS",$J,"SIG",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1
.I $L(^TMP("PS",$J,"SIG",PSOX2,0))+$L(Z1)<245 S ^TMP("PS",$J,"SIG",PSOX2,0)=^TMP("PS",$J,"SIG",PSOX2,0)_" "_Z1
.E S PSOX2=PSOX2+1,^TMP("PS",$J,"SIG",PSOX2,0)=Z1
EN K Z1,Z0,PSOX1 Q
;
SIG1 ;expands SIG for condensed list
F Z0=1:1:$L(X," ") G:Z0="" EN 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("PS",$J,TFN,"SIG",1,0))']"" S ^TMP("PS",$J,TFN,"SIG",1,0)=Z1,^TMP("PS",$J,TFN,"SIG",0)=1 Q
.F PSOX1=0:0 S PSOX1=$O(^TMP("PS",$J,TFN,"SIG",PSOX1)) Q:'PSOX1 S PSOX2=PSOX1
.I $L(^TMP("PS",$J,TFN,"SIG",PSOX2,0))+$L(Z1)<245 S ^TMP("PS",$J,TFN,"SIG",PSOX2,0)=^TMP("PS",$J,TFN,"SIG",PSOX2,0)_" "_Z1
.E S PSOX2=PSOX2+1,^TMP("PS",$J,TFN,"SIG",PSOX2,0)=Z1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOORRL1 5206 printed Sep 23, 2025@20:08:44 Page 2
PSOORRL1 ;BHAM ISC/SAB,TJH - sub-module for PSOORRL ;May 29, 2020@14:36:35
+1 ;;7.0;OUTPATIENT PHARMACY;**20,46,132,159,441**;DEC 1997;Build 208
+2 ;External reference to ^PS(51.2 supported by DBIA 2226
+3 ;External reference to ^PS(50.607 supported by DBIA 2221
+4 ;External reference to ^PS(50.606 supported by DBIA 2174
+5 ;External reference to ^PS(51 supported by DBIA 2224
+6 ;External reference to ^PS(50.7 supported by DBIA 2223
+7 ;External reference to ^PSDRUG supported by DBIA 221
+8 ;External reference to ^PS(55 supported by DBIA 2228
+9 ;
MDR ;
+1 SET ^TMP("PS",$JOB,"MDR",0)=0
SET (MDR,MR)=0
FOR
SET MR=$ORDER(^PSRX(IFN,"MEDR",MR))
if 'MR
QUIT
Begin DoDot:1
+2 if '$DATA(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0))
QUIT
SET MDR=MDR+1
+3 IF $PIECE($GET(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0)),"^",3)]""
SET ^TMP("PS",$JOB,"MDR",MDR,0)=$PIECE(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0),"^",3)
+4 IF $DATA(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0))
IF $PIECE($GET(^(0)),"^",3)']""
SET ^TMP("PS",$JOB,"MDR",MDR,0)=$PIECE(^PS(51.2,+^PSRX(IFN,"MEDR",MR,0),0),"^")
+5 SET ^TMP("PS",$JOB,"MDR",0)=^TMP("PS",$JOB,"MDR",0)+1
End DoDot:1
+6 QUIT
+7 ;
PEN ;
+1 ;BHW;PSO*7*159;New SD Variable
+2 NEW SD
+3 if '$DATA(^PS(52.41,IFN,0))!($PIECE($GET(^PS(52.41,IFN,0)),"^",3)="RF")
QUIT
SET PSOR=^PS(52.41,IFN,0)
+4 SET ^TMP("PS",$JOB,0)=$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),"^"))
+5 IF $PIECE(PSOR,"^",9)
Begin DoDot:1
+6 SET ^TMP("PS",$JOB,"DD",0)=1
+7 SET COD=$SELECT('$GET(^PSDRUG($PIECE(PSOR,"^",9),"I")):1,+$GET(^PSDRUG($PIECE(PSOR,"^",9),"I"))>DT:1,1:0)
+8 SET ^TMP("PS",$JOB,"DD",1,0)=$PIECE(PSOR,"^",9)_"^^"_$SELECT($PIECE($GET(^PSDRUG($PIECE(PSOR,"^",9),2)),"^",3)["U"&(COD):$PIECE(PSOR,"^",9),1:"")
KILL COD
End DoDot:1
+9 SET ^TMP("PS",$JOB,0)=^TMP("PS",$JOB,0)_"^"_$SELECT(...
... $GET(^PS(51.2,+$PIECE(PSOR,"^",15),0))]"":$PIECE(^PS(51.2,+$PIECE(PSOR,"^",15),0),"^",3),1:"")_"^^"_$PIECE(PSOR,"^",11)_"^"_$PIECE($PIECE(PSOR,"^",6),".")_"^"_$SELECT($PIECE(PSOR,"^",3)'="HD":"PENDING",1:" ON HOLD")_"^^"_$PIECE(PSOR,"^",10)
+10 SET $PIECE(^TMP("PS",$JOB,0),"^",11)=$PIECE(PSOR,"^")
+11 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,"SCH",SD,0)=$PIECE(^PS(52.41,IFN,1,SCH,1),"^")
SET ^TMP("PS",$JOB,"SCH",0)=SD
+12 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,"SIG",SD,0)=$PIECE(^PS(52.41,IFN,"SIG",SCH,0),"^")
SET ^TMP("PS",$JOB,"SIG",0)=SD
+13 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,"SIO",0)=SD
Begin DoDot:1
+14 FOR SG=1:1:$LENGTH(MIG," ")
if $LENGTH($GET(^TMP("PS",$JOB,"SIO",SD,0))_" "_$PIECE(MIG," ",SG))>80
SET SD=SD+1
SET ^TMP("PS",$JOB,"SIO",0)=SD
SET ^TMP("PS",$JOB,"SIO",SD,0)=$GET(^TMP("PS",$JOB,"SIO",SD,0))_" "_$PIECE(MIG," ",SG)
End DoDot:1
+15 ;*441-IND
if $PIECE($GET(^PS(52.41,IFN,4)),U,2)]""
SET ^TMP("PS",$JOB,"IND",0)=1
SET ^TMP("PS",$JOB,"IND",1,0)=$PIECE(^PS(52.41,IFN,4),U,2)
END KILL FL,SD,SCH,%T,Y,ST,ST0,PSBDT,PSEDT,IFN,EXDT,RX0,RX2,RX3,TRM,I,X,Z1,Z0,PSOX1,PSOX2,PSOR,STA,TFN,X1,X2,SC,MDR,MR,IFN,MIG,INST
+1 KILL BDT,EDT,IEN,ITFN,RXNUM
+2 QUIT
NVA ;non-va meds display
+1 if '$DATA(^PS(55,DFN,"NVA",IFN,0))!('$PIECE($GET(^PS(55,DFN,"NVA",IFN,0)),"^"))
QUIT
+2 SET PSOR=^PS(55,DFN,"NVA",IFN,0)
+3 SET ^TMP("PS",$JOB,0)=$SELECT($PIECE(PSOR,"^",2):$PIECE($GET(^PSDRUG($PIECE(PSOR,"^",2),0)),"^"),1:$PIECE(^PS(50.7,$PIECE(PSOR,"^"),0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^PS(50.7,$PIECE(PSOR,"^"),0),"^",2),0),"^"))
+4 IF $PIECE(PSOR,"^",2)
Begin DoDot:1
+5 SET ^TMP("PS",$JOB,"DD",0)=1
+6 SET COD=$SELECT('$GET(^PSDRUG($PIECE(PSOR,"^",2),"I")):1,+$GET(^PSDRUG($PIECE(PSOR,"^",2),"I"))>DT:1,1:0)
+7 SET ^TMP("PS",$JOB,"DD",1,0)=$PIECE(PSOR,"^",2)_"^^"_$SELECT($PIECE($GET(^PSDRUG($PIECE(PSOR,"^",2),2)),"^",3)["U"&(COD):$PIECE(PSOR,"^",2),1:"")
KILL COD
End DoDot:1
+8 SET ^TMP("PS",$JOB,0)=^TMP("PS",$JOB,0)_"^^^N/A^"_$PIECE($PIECE(PSOR,"^",9),".")_"^"_$SELECT('$PIECE(PSOR,"^",7):"ACTIVE",1:"DISCONTINUED")_"^^N/A^^^"_$PIECE(PSOR,"^",8)
+9 SET ^TMP("PS",$JOB,"SCH",1,0)=$PIECE(PSOR,"^",5)
SET ^TMP("PS",$JOB,"SCH",0)=1
+10 SET ^TMP("PS",$JOB,"SIG",1,0)=$PIECE(PSOR,"^",3)_" "_$PIECE(PSOR,"^",4)_" "_$PIECE(PSOR,"^",5)
SET ^TMP("PS",$JOB,"SIG",0)=1
+11 SET ^TMP("PS",$JOB,"SIO",1,0)=$PIECE(PSOR,"^",3)_" "_$PIECE(PSOR,"^",4)_" "_$PIECE(PSOR,"^",5)
SET ^TMP("PS",$JOB,"SIO",0)=1
+12 KILL PSOR
+13 ;*441-IND
if $PIECE($GET(^PS(55,DFN,"NVA",IFN,2)),U)]""
SET ^TMP("PS",$JOB,"IND",0)=1
SET ^TMP("PS",$JOB,"IND",1,0)=$PIECE($GET(^PS(55,DFN,"NVA",IFN,2)),U)
+14 QUIT
+15 ;
SIG ;expands SIG expanded list
+1 FOR Z0=1:1:$LENGTH(X," ")
if Z0=""
GOTO EN
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("PS",$JOB,"SIG",1,0))']""
SET ^TMP("PS",$JOB,"SIG",1,0)=Z1
SET ^TMP("PS",$JOB,"SIG",0)=1
QUIT
+5 FOR PSOX1=0:0
SET PSOX1=$ORDER(^TMP("PS",$JOB,"SIG",PSOX1))
if 'PSOX1
QUIT
SET PSOX2=PSOX1
+6 IF $LENGTH(^TMP("PS",$JOB,"SIG",PSOX2,0))+$LENGTH(Z1)<245
SET ^TMP("PS",$JOB,"SIG",PSOX2,0)=^TMP("PS",$JOB,"SIG",PSOX2,0)_" "_Z1
+7 IF '$TEST
SET PSOX2=PSOX2+1
SET ^TMP("PS",$JOB,"SIG",PSOX2,0)=Z1
End DoDot:1
EN KILL Z1,Z0,PSOX1
QUIT
+1 ;
SIG1 ;expands SIG for condensed list
+1 FOR Z0=1:1:$LENGTH(X," ")
if Z0=""
GOTO EN
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("PS",$JOB,TFN,"SIG",1,0))']""
SET ^TMP("PS",$JOB,TFN,"SIG",1,0)=Z1
SET ^TMP("PS",$JOB,TFN,"SIG",0)=1
QUIT
+5 FOR PSOX1=0:0
SET PSOX1=$ORDER(^TMP("PS",$JOB,TFN,"SIG",PSOX1))
if 'PSOX1
QUIT
SET PSOX2=PSOX1
+6 IF $LENGTH(^TMP("PS",$JOB,TFN,"SIG",PSOX2,0))+$LENGTH(Z1)<245
SET ^TMP("PS",$JOB,TFN,"SIG",PSOX2,0)=^TMP("PS",$JOB,TFN,"SIG",PSOX2,0)_" "_Z1
+7 IF '$TEST
SET PSOX2=PSOX2+1
SET ^TMP("PS",$JOB,TFN,"SIG",PSOX2,0)=Z1
End DoDot:1
+8 QUIT
