PSOHLDA ;BIR/MFR - HOLD/UNHOLD functionality (cont.) ;08/23/17 20:01
;;7.0;OUTPATIENT PHARMACY;**148,225,386,441**;DEC 1997;Build 208
;
HOLD ;hold function
I $P($G(^PSRX(DA,"STA")),"^")=3 Q
S RSDT=$S($P(^PSRX(DA,2),"^",13):$P(^PSRX(DA,3),"^"),1:"@"),(PSUS,ACT,RXF,RFN,I)=0 F S I=$O(^PSRX(DA,1,I)) Q:'I D
.S RXF=I,RFN=RFN+1 S:RFN=1 RSDT=$S('$P(^PSRX(DA,1,I,0),"^",18):$P(^PSRX(DA,2),"^",2),1:$P(^PSRX(DA,1,I,0),"^"))
.I RFN>1,'$P(^PSRX(DA,1,I,0),"^",18) S RSDT=$P(^PSRX(DA,1,RXF-1,0),"^") Q
.S:RFN>1 RSDT=$P(^PSRX(DA,1,RXF,0),"^")
I RXF D
.S (PSDA,DA(1))=DA,DA=RXF,DIE="^PSRX("_DA(1)_",1,",DR="4" D ^DIE
.S $P(^PSRX(DA(1),1,DA,0),"^",3)=$S($G(FLD(99.1))]"":$E(FLD(99.1),1,60),1:"")
.S DA=PSDA K DA(1)
S DIE="^PSRX(",DR=$S('RXF&('$P(^PSRX(DA,2),"^",13)):"22///@;",1:"")_"99///"_FLD(99)_";99.1///^S X=FLD(99.1);99.2///"_DT_";100///3;101///"_RSDT D ^DIE Q:$D(Y)
S:$G(PSOHD) VALMSG="RX# "_$P(^PSRX(DA,0),"^")_" has been placed in a hold status."
K RXRS(DA)
I $G(^PSRX(DA,"PARK")) D KILLPARK^PSOPRK(DA),RXACT^PSOPRK(DA,"UPK") ;441 PAPI
I +$G(PSDA) S DA=$O(^PS(52.5,"B",PSDA,0)) I DA S:$P($G(^PS(52.5,DA,"P")),"^")=0 PSUS=1 S DIK="^PS(52.5," D ^DIK K DA,DIK
S:+$G(PSDA) DA=PSDA D RXACT^PSOHLD(DA,"H",$$GET1^DIQ(52,DA,99),$$GET1^DIQ(52,DA,99.1),$G(PSUS))
S PSOHNX=+$P($G(^PSRX(+$G(DA),"H")),"^") D
.I $G(PSOHNX),$P($G(^PSRX(DA,"H")),"^",2)'="" S COMM=$P($G(^("H")),"^",2) Q
.S COMM="Medication placed on Hold "_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)
D EN^PSOHLSN1(DA,"OH","",COMM,PSONOOR) K COMM,PSOHNX
;
; - Closes any OPEN/UNRESOLVED REJECTs and Reverses ECME Claim
D REVERSE^PSOBPSU1(DA,+$G(RXF),"HLD",2)
;
K PSUS,RXF,I,FDA,DIC,DIE,DR,Y,X,%,%I,%H,RSDT
Q
;
RMP ;remove Rx if found in array PSORX("PSOL")
Q:'$G(DA)
N I,J,K,PSOX2,PSOX3,PSOX9 S I=0
F S I=$O(PSORX("PSOL",I)) Q:'I S PSOX2=PSORX("PSOL",I) D:PSOX2[(DA_",")
.S PSOX9="",K=0 F J=1:1 S PSOX3=$P(PSOX2,",",J) Q:'PSOX3 D
..I PSOX3=DA,$P($G(^PSRX(DA,"STA")),"^")=3 S K=1 Q
..S PSOX9=PSOX9_$S('PSOX9:"",1:",")_PSOX3
.I K S:PSOX9]"" PSORX("PSOL",I)=PSOX9_"," K:PSOX9="" PSORX("PSOL",I) D:$D(BBRX(I)) RMB
Q
RMB ;remove Rx if found in array BBRX()
S PSOX2=BBRX(I) D:PSOX2[(DA_",")
.S PSOX9="" F J=1:1 S PSOX3=$P(PSOX2,",",J) Q:'PSOX3 S:PSOX3'=DA PSOX9=PSOX9_$S('PSOX9:"",1:",")_PSOX3
.S:PSOX9]"" BBRX(I)=PSOX9_"," K:PSOX9="" BBRX(I)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLDA 2374 printed Dec 13, 2024@02:29:42 Page 2
PSOHLDA ;BIR/MFR - HOLD/UNHOLD functionality (cont.) ;08/23/17 20:01
+1 ;;7.0;OUTPATIENT PHARMACY;**148,225,386,441**;DEC 1997;Build 208
+2 ;
HOLD ;hold function
+1 IF $PIECE($GET(^PSRX(DA,"STA")),"^")=3
QUIT
+2 SET RSDT=$SELECT($PIECE(^PSRX(DA,2),"^",13):$PIECE(^PSRX(DA,3),"^"),1:"@")
SET (PSUS,ACT,RXF,RFN,I)=0
FOR
SET I=$ORDER(^PSRX(DA,1,I))
if 'I
QUIT
Begin DoDot:1
+3 SET RXF=I
SET RFN=RFN+1
if RFN=1
SET RSDT=$SELECT('$PIECE(^PSRX(DA,1,I,0),"^",18):$PIECE(^PSRX(DA,2),"^",2),1:$PIECE(^PSRX(DA,1,I,0),"^"))
+4 IF RFN>1
IF '$PIECE(^PSRX(DA,1,I,0),"^",18)
SET RSDT=$PIECE(^PSRX(DA,1,RXF-1,0),"^")
QUIT
+5 if RFN>1
SET RSDT=$PIECE(^PSRX(DA,1,RXF,0),"^")
End DoDot:1
+6 IF RXF
Begin DoDot:1
+7 SET (PSDA,DA(1))=DA
SET DA=RXF
SET DIE="^PSRX("_DA(1)_",1,"
SET DR="4"
DO ^DIE
+8 SET $PIECE(^PSRX(DA(1),1,DA,0),"^",3)=$SELECT($GET(FLD(99.1))]"":$EXTRACT(FLD(99.1),1,60),1:"")
+9 SET DA=PSDA
KILL DA(1)
End DoDot:1
+10 SET DIE="^PSRX("
SET DR=$SELECT('RXF&('$PIECE(^PSRX(DA,2),"^",13)):"22///@;",1:"")_"99///"_FLD(99)_";99.1///^S X=FLD(99.1);99.2///"_DT_";100///3;101///"_RSDT
DO ^DIE
if $DATA(Y)
QUIT
+11 if $GET(PSOHD)
SET VALMSG="RX# "_$PIECE(^PSRX(DA,0),"^")_" has been placed in a hold status."
+12 KILL RXRS(DA)
+13 ;441 PAPI
IF $GET(^PSRX(DA,"PARK"))
DO KILLPARK^PSOPRK(DA)
DO RXACT^PSOPRK(DA,"UPK")
+14 IF +$GET(PSDA)
SET DA=$ORDER(^PS(52.5,"B",PSDA,0))
IF DA
if $PIECE($GET(^PS(52.5,DA,"P")),"^")=0
SET PSUS=1
SET DIK="^PS(52.5,"
DO ^DIK
KILL DA,DIK
+15 if +$GET(PSDA)
SET DA=PSDA
DO RXACT^PSOHLD(DA,"H",$$GET1^DIQ(52,DA,99),$$GET1^DIQ(52,DA,99.1),$GET(PSUS))
+16 SET PSOHNX=+$PIECE($GET(^PSRX(+$GET(DA),"H")),"^")
Begin DoDot:1
+17 IF $GET(PSOHNX)
IF $PIECE($GET(^PSRX(DA,"H")),"^",2)'=""
SET COMM=$PIECE($GET(^("H")),"^",2)
QUIT
+18 SET COMM="Medication placed on Hold "_$EXTRACT(DT,4,5)_"-"_$EXTRACT(DT,6,7)_"-"_$EXTRACT(DT,2,3)
End DoDot:1
+19 DO EN^PSOHLSN1(DA,"OH","",COMM,PSONOOR)
KILL COMM,PSOHNX
+20 ;
+21 ; - Closes any OPEN/UNRESOLVED REJECTs and Reverses ECME Claim
+22 DO REVERSE^PSOBPSU1(DA,+$GET(RXF),"HLD",2)
+23 ;
+24 KILL PSUS,RXF,I,FDA,DIC,DIE,DR,Y,X,%,%I,%H,RSDT
+25 QUIT
+26 ;
RMP ;remove Rx if found in array PSORX("PSOL")
+1 if '$GET(DA)
QUIT
+2 NEW I,J,K,PSOX2,PSOX3,PSOX9
SET I=0
+3 FOR
SET I=$ORDER(PSORX("PSOL",I))
if 'I
QUIT
SET PSOX2=PSORX("PSOL",I)
if PSOX2[(DA_",")
Begin DoDot:1
+4 SET PSOX9=""
SET K=0
FOR J=1:1
SET PSOX3=$PIECE(PSOX2,",",J)
if 'PSOX3
QUIT
Begin DoDot:2
+5 IF PSOX3=DA
IF $PIECE($GET(^PSRX(DA,"STA")),"^")=3
SET K=1
QUIT
+6 SET PSOX9=PSOX9_$SELECT('PSOX9:"",1:",")_PSOX3
End DoDot:2
+7 IF K
if PSOX9]""
SET PSORX("PSOL",I)=PSOX9_","
if PSOX9=""
KILL PSORX("PSOL",I)
if $DATA(BBRX(I))
DO RMB
End DoDot:1
+8 QUIT
RMB ;remove Rx if found in array BBRX()
+1 SET PSOX2=BBRX(I)
if PSOX2[(DA_",")
Begin DoDot:1
+2 SET PSOX9=""
FOR J=1:1
SET PSOX3=$PIECE(PSOX2,",",J)
if 'PSOX3
QUIT
if PSOX3'=DA
SET PSOX9=PSOX9_$SELECT('PSOX9:"",1:",")_PSOX3
+3 if PSOX9]""
SET BBRX(I)=PSOX9_","
if PSOX9=""
KILL BBRX(I)
End DoDot:1
+4 QUIT
