PSOCSRL ;BIR/BHW - release interface for control substance pkg ; 1/29/20 12:46pm
;;7.0;OUTPATIENT PHARMACY;**27,71,118,148,247,373,385,596,629**;DEC 1997;Build 1
;External reference to ^PSDRUG supported by DBIA 221
;External reference to ^PS(55 supported by DBIA 2228
;External reference to ^PS(59.7 supported by DBIA 694
;External reference to $$SERV^IBARX1 supported by DBIA 2245
EN(RXP,XTYPE,PSRH) ;
N NCPDP
I '$D(PSOPAR) D G:'$D(PSOPAR) EX
.D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,?5,"Site Parameters must be defined to use the Release option!",! Q
.S PSOCSUB=1
K XFLAG D CS^PSOCMOPB(RXP) I $G(XFLAG) K XFLAG Q
S Y=$G(^PS(59,PSOSITE,"IB")),PSOIBSS=$$SERV^IBARX1(+Y) I 'PSOIBSS D IBSSR^PSOUTL I 'PSOIBFL D G EX
.W $C(7),!!,"The IB SERVICE/SECTION defined in your site parameter file is not valid.",!,"You will not be able to release any medication until this is corrected!",!
W !! S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2)
Q:'$D(^XUSEC("PSORPH",PSRH))
I '$D(^PSRX(+$G(RXP),0))!($G(RXP)']"") W !?7,$C(7),$C(7),$C(7)," NON-EXISTENT PRESCRIPTION" G EX
D:$P($G(^PS(55,+$P(^PSRX(+RXP,0),"^",2),0)),"^",6)'=2 EN^PSOHLUP($P(^PSRX(+RXP,0),"^",2))
I +$P($G(^PSRX(+RXP,"STA")),"^")=13!+$P($G(^PSRX(+RXP,0)),"^",2)=0 W !?7,$C(7),$C(7)," PRESCRIPTION IS A DELETED PERSCRIPTION NUMBER" G EX
I +$P($G(^PSRX(+RXP,"STA")),"^"),$S($P(^("STA"),"^")=2:0,$P(^("STA"),"^")=5:0,$P(^("STA"),"^")=11:0,$P(^("STA"),"^")=12:0,1:1) G EX
G:$G(XTYPE)]"" REF
ORI ;orig
K LBLP,ISUF I $P(^PSRX(RXP,2),"^",13) S Y=$P(^PSRX(RXP,2),"^",13) X ^DD("DD") W !!?7,$C(7),$C(7),"ORIGINAL PRESCRIPTION WAS LAST RELEASED ON "_Y,! G EX
I $P(^PSRX(RXP,2),"^",15) S RESK=$P(^(2),"^",15) W !,"Original Fill returned to stock on "_$E(RESK,4,5)_"/"_$E(RESK,6,7)_"/"_$E(RESK,2,3),!
S PSOCPN=$P(^PSRX(RXP,0),"^",2),QTY=$P($G(^PSRX(RXP,0)),"^",7),QDRUG=$P(^PSRX(RXP,0),"^",6)
I '$P($G(^PSRX(RXP,2)),"^",13),+$P($G(^(2)),"^",2)'<PSIN S RXFD=$P(^(2),"^",2) D G:$G(PSOUT) EX D:$G(LBLP) UPDATE I $G(ISUF) D UPDATE
.S SUPN=$O(^PS(52.5,"B",RXP,0)) I SUPN,$D(^PS(52.5,"C",RXFD,SUPN)),$G(^PS(52.5,SUPN,"P"))'=1 S ISUF=1 Q
.;
.F LBL=0:0 S LBL=$O(^PSRX(RXP,"L",LBL)) Q:'LBL I '+$P(^PSRX(RXP,"L",LBL,0),"^",2),'$P(^(0),"^",5) S LBLP=1
.Q:'$G(LBLP) D ASK Q:$G(PSOUT)
.;
.; - Checking for OPEN/UNRESOLVED 3rd. Party Payer Rejects / NDC Editing
.I $$MANREL^PSOBPSUT(RXP,0)="^" K LBLP Q
.;
.S:$D(^PSDRUG(QDRUG,660.1)) ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY
.Q:$P($G(^PSRX(RXP,2)),"^",13)
.D NOW^%DTC S DIE="^PSRX(",DA=RXP,DR="31///"_%_";23////"_PSRH_";32.1////@;32.2////@" ; p629 added 32.1 and 32.2
.D ^DIE K DIE,DR,DA,LBL
.D EN^PSOHLSN1(RXP,"ZD")
.; ECME - 3rd Party Billing
.;
.; - Notifying IB through ECME of the Rx being released
.D IBSEND^PSOBPSUT(RXP,0)
G EX
REF ;release ref or par
K LBLP,ISUF,IFN D QTY S:($P($G(XTYPE),"^")="P") $P(^PSRX(RXP,"TYPE"),"^")=0
EX K OUT,RX2,RXFD,RESK,ISUF,SUPN,%,DIC,IFN,J,DA,DR,DIE,X,Y,RXP,REC,DIRUT,PSOCPN,PSOCPRX,PSOIBSS,PSOIBFL,PSOIBLP,PSOIBST,QDRUG,QTY,XTYPE,PSRH,Y,PSIN
K DIR,DUOUT,DTOUT,LBL,LBLP,PSOUT
Q
UPDATE I $G(ISUF) W $C(7),!!?7,$S($P(XTYPE,"^")=1:"RE",$P(XTYPE,"^")="P":"PARTIAL ",1:"ORIGINAL")_"FILL ON SUSPENSE !",!,$C(7) Q
S PSOCPRX=$P(^PSRX(RXP,0),"^") D CP^PSOCP
W !?7,"PRESCRIPTION NUMBER "_$P(^PSRX(RXP,0),"^")_" RELEASED"
I $$STATUS^PSOBPSUT(RXP)]"",$$WINFILL^PSODISPS(RXP) D SIGMSG^PSODISPS
Q
QTY S PSOCPN=$P(^PSRX(RXP,0),"^",2),QDRUG=$P(^PSRX(RXP,0),"^",6) K LBLP
D:$P($G(^PSRX(RXP,$P(XTYPE,"^"),$P(XTYPE,"^",2),0)),"^")'<PSIN K ISUF,LBLP G:$G(PSOUT) EX
.S RXFD=$E($P(^PSRX(RXP,$P(XTYPE,"^"),$P(XTYPE,"^",2),0),"^"),1,7),SUPN=$O(^PS(52.5,"B",RXP,0)) I SUPN,$D(^PS(52.5,"C",RXFD,SUPN)),$G(^PS(52.5,SUPN,"P"))'=1 S ISUF=1 D UPDATE Q
.I $P(^PSRX(RXP,$P(XTYPE,"^"),$P(XTYPE,"^",2),0),"^",$S($P($G(XTYPE),"^"):18,1:19))]""!($P(^(0),"^",16)) K IFN Q
.;
.F LBL=0:0 S LBL=$O(^PSRX(RXP,"L",LBL)) Q:'LBL I $P(^PSRX(RXP,"L",LBL,0),"^",2)=$S('$P(XTYPE,"^"):(99-$P(XTYPE,"^",2)),1:$P(XTYPE,"^",2)) S LBLP=1
.Q:'$G(LBLP) D ASK Q:$G(PSOUT)
.;
.; - Checking for OPEN/UNRESOLVED 3rd. Party Payer Rejects / NDC Editing
.I XTYPE,$$MANREL^PSOBPSUT(RXP,$P(XTYPE,"^",2))="^" K LBLP Q
.;
.S IFN=$P(XTYPE,"^",2) S:$G(^PSDRUG(QDRUG,660.1))]"" QTY=$P(^PSRX(RXP,$P(XTYPE,"^"),$P(XTYPE,"^",2),0),"^",4),^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY
.D NOW^%DTC S DIE="^PSRX("_RXP_","""_$P(XTYPE,"^")_""","
.S DA(1)=RXP,DA=$P(XTYPE,"^",2)
.S DR=$S(+XTYPE:17,1:8)_"///"_%_";"_$S(+XTYPE:4,1:.05)_"////"_PSRH
.D ^DIE K DIE,DR,DA
.K PSODISPP S:'$P($G(XTYPE),"^") PSODISPP=1 D EN^PSOHLSN1(RXP,"ZD") K PSODISPP
.;
.; - Notifying IB through ECME of the Rx being released
.I XTYPE D IBSEND^PSOBPSUT(RXP,$P(XTYPE,"^",2))
.;
.K:+XTYPE ^PSRX("ACP",$P($G(^PSRX(RXP,0)),"^",2),$P($G(^PSRX(RXP,1,$P(XTYPE,"^",2),0)),"^"),$P(XTYPE,"^",2),RXP)
.I +XTYPE,$G(IFN),'$G(ISUF) S PSOCPRX=$P(^PSRX(RXP,0),"^"),YY=$P(XTYPE,"^",2) D CP^PSOCP
W:$G(IFN) !!?7,"PRESCRIPTION NUMBER "_$P(^PSRX(RXP,0),"^")_$S('+$G(XTYPE):" Partial Fill",1:" REFILL")_" #"_$P(XTYPE,"^",2)_" RELEASED"
W:'$G(IFN) !!?7,$S(+$G(XTYPE):"REFILL",1:"PARTIAL")_" #"_$P(XTYPE,"^",2)_" NOT RELEASED"
I $G(IFN),$$STATUS^PSOBPSUT(RXP)]"",$$WINFILL^PSODISPS(RXP) D SIGMSG^PSODISPS
K IFN
Q
ASK ;confirm
W ! K DIR S DIR(0)="SA^1:YES;0:NO",DIR("B")="Yes",DIR("A",1)="Are You sure you want to release "_$S($G(XTYPE)']"":"Original ",$P(XTYPE,"^")=1:"Re",1:"Partial ")_"fill"_$S($P(XTYPE,"^",2):" #"_$P(XTYPE,"^",2),1:"")
S DIR("A")="for Prescription #"_$P(^PSRX(RXP,0),"^")_": " D ^DIR K DIR
S:'Y!($D(DIRUT)) PSOUT=1
;bingo board call
I Y,$G(XTYPE)="",$P(^PSRX(RXP,0),"^",11)["W" S BINGRO="W",BINGNAM=$P(^PSRX(RXP,0),"^",2),BINGDIV=$P(^PSRX(RXP,2),"^",9)
I Y,$G(XTYPE)["P",$P($G(^PSRX(RXP,"P",$P(XTYPE,"^",2),0)),"^",2)["W" S BINGRPR="W",BNGPDV=$P(^PSRX(RXP,"P",$P(XTYPE,"^",2),0),"^",9),BINGNAM=$P($G(^PSRX(RXP,0)),"^",2)
I Y,+$G(XTYPE)=1,$P($G(^PSRX(RXP,1,$P(XTYPE,"^",2),0)),"^",2)["W" S BINGRPR="W",BNGRDV=$P(^PSRX(RXP,1,$P(XTYPE,"^",2),0),"^",9),BINGNAM=$P($G(^PSRX(RXP,0)),"^",2)
I $D(DISGROUP),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCSRL 6220 printed Sep 23, 2025@20:02:23 Page 2
PSOCSRL ;BIR/BHW - release interface for control substance pkg ; 1/29/20 12:46pm
+1 ;;7.0;OUTPATIENT PHARMACY;**27,71,118,148,247,373,385,596,629**;DEC 1997;Build 1
+2 ;External reference to ^PSDRUG supported by DBIA 221
+3 ;External reference to ^PS(55 supported by DBIA 2228
+4 ;External reference to ^PS(59.7 supported by DBIA 694
+5 ;External reference to $$SERV^IBARX1 supported by DBIA 2245
EN(RXP,XTYPE,PSRH) ;
+1 NEW NCPDP
+2 IF '$DATA(PSOPAR)
Begin DoDot:1
+3 DO ^PSOLSET
IF '$DATA(PSOPAR)
WRITE $CHAR(7),!!,?5,"Site Parameters must be defined to use the Release option!",!
QUIT
+4 SET PSOCSUB=1
End DoDot:1
if '$DATA(PSOPAR)
GOTO EX
+5 KILL XFLAG
DO CS^PSOCMOPB(RXP)
IF $GET(XFLAG)
KILL XFLAG
QUIT
+6 SET Y=$GET(^PS(59,PSOSITE,"IB"))
SET PSOIBSS=$$SERV^IBARX1(+Y)
IF 'PSOIBSS
DO IBSSR^PSOUTL
IF 'PSOIBFL
Begin DoDot:1
+7 WRITE $CHAR(7),!!,"The IB SERVICE/SECTION defined in your site parameter file is not valid.",!,"You will not be able to release any medication until this is corrected!",!
End DoDot:1
GOTO EX
+8 WRITE !!
SET PSIN=+$PIECE($GET(^PS(59.7,1,49.99)),"^",2)
+9 if '$DATA(^XUSEC("PSORPH",PSRH))
QUIT
+10 IF '$DATA(^PSRX(+$GET(RXP),0))!($GET(RXP)']"")
WRITE !?7,$CHAR(7),$CHAR(7),$CHAR(7)," NON-EXISTENT PRESCRIPTION"
GOTO EX
+11 if $PIECE($GET(^PS(55,+$PIECE(^PSRX(+RXP,0),"^",2),0)),"^",6)'=2
DO EN^PSOHLUP($PIECE(^PSRX(+RXP,0),"^",2))
+12 IF +$PIECE($GET(^PSRX(+RXP,"STA")),"^")=13!+$PIECE($GET(^PSRX(+RXP,0)),"^",2)=0
WRITE !?7,$CHAR(7),$CHAR(7)," PRESCRIPTION IS A DELETED PERSCRIPTION NUMBER"
GOTO EX
+13 IF +$PIECE($GET(^PSRX(+RXP,"STA")),"^")
IF $SELECT($PIECE(^("STA"),"^")=2:0,$PIECE(^("STA"),"^")=5:0,$PIECE(^("STA"),"^")=11:0,$PIECE(^("STA"),"^")=12:0,1:1)
GOTO EX
+14 if $GET(XTYPE)]""
GOTO REF
ORI ;orig
+1 KILL LBLP,ISUF
IF $PIECE(^PSRX(RXP,2),"^",13)
SET Y=$PIECE(^PSRX(RXP,2),"^",13)
XECUTE ^DD("DD")
WRITE !!?7,$CHAR(7),$CHAR(7),"ORIGINAL PRESCRIPTION WAS LAST RELEASED ON "_Y,!
GOTO EX
+2 IF $PIECE(^PSRX(RXP,2),"^",15)
SET RESK=$PIECE(^(2),"^",15)
WRITE !,"Original Fill returned to stock on "_$EXTRACT(RESK,4,5)_"/"_$EXTRACT(RESK,6,7)_"/"_$EXTRACT(RESK,2,3),!
+3 SET PSOCPN=$PIECE(^PSRX(RXP,0),"^",2)
SET QTY=$PIECE($GET(^PSRX(RXP,0)),"^",7)
SET QDRUG=$PIECE(^PSRX(RXP,0),"^",6)
+4 IF '$PIECE($GET(^PSRX(RXP,2)),"^",13)
IF +$PIECE($GET(^(2)),"^",2)'<PSIN
SET RXFD=$PIECE(^(2),"^",2)
Begin DoDot:1
+5 SET SUPN=$ORDER(^PS(52.5,"B",RXP,0))
IF SUPN
IF $DATA(^PS(52.5,"C",RXFD,SUPN))
IF $GET(^PS(52.5,SUPN,"P"))'=1
SET ISUF=1
QUIT
+6 ;
+7 FOR LBL=0:0
SET LBL=$ORDER(^PSRX(RXP,"L",LBL))
if 'LBL
QUIT
IF '+$PIECE(^PSRX(RXP,"L",LBL,0),"^",2)
IF '$PIECE(^(0),"^",5)
SET LBLP=1
+8 if '$GET(LBLP)
QUIT
DO ASK
if $GET(PSOUT)
QUIT
+9 ;
+10 ; - Checking for OPEN/UNRESOLVED 3rd. Party Payer Rejects / NDC Editing
+11 IF $$MANREL^PSOBPSUT(RXP,0)="^"
KILL LBLP
QUIT
+12 ;
+13 if $DATA(^PSDRUG(QDRUG,660.1))
SET ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY
+14 if $PIECE($GET(^PSRX(RXP,2)),"^",13)
QUIT
+15 ; p629 added 32.1 and 32.2
DO NOW^%DTC
SET DIE="^PSRX("
SET DA=RXP
SET DR="31///"_%_";23////"_PSRH_";32.1////@;32.2////@"
+16 DO ^DIE
KILL DIE,DR,DA,LBL
+17 DO EN^PSOHLSN1(RXP,"ZD")
+18 ; ECME - 3rd Party Billing
+19 ;
+20 ; - Notifying IB through ECME of the Rx being released
+21 DO IBSEND^PSOBPSUT(RXP,0)
End DoDot:1
if $GET(PSOUT)
GOTO EX
if $GET(LBLP)
DO UPDATE
IF $GET(ISUF)
DO UPDATE
+22 GOTO EX
REF ;release ref or par
+1 KILL LBLP,ISUF,IFN
DO QTY
if ($PIECE($GET(XTYPE),"^")="P")
SET $PIECE(^PSRX(RXP,"TYPE"),"^")=0
EX KILL OUT,RX2,RXFD,RESK,ISUF,SUPN,%,DIC,IFN,J,DA,DR,DIE,X,Y,RXP,REC,DIRUT,PSOCPN,PSOCPRX,PSOIBSS,PSOIBFL,PSOIBLP,PSOIBST,QDRUG,QTY,XTYPE,PSRH,Y,PSIN
+1 KILL DIR,DUOUT,DTOUT,LBL,LBLP,PSOUT
+2 QUIT
UPDATE IF $GET(ISUF)
WRITE $CHAR(7),!!?7,$SELECT($PIECE(XTYPE,"^")=1:"RE",$PIECE(XTYPE,"^")="P":"PARTIAL ",1:"ORIGINAL")_"FILL ON SUSPENSE !",!,$CHAR(7)
QUIT
+1 SET PSOCPRX=$PIECE(^PSRX(RXP,0),"^")
DO CP^PSOCP
+2 WRITE !?7,"PRESCRIPTION NUMBER "_$PIECE(^PSRX(RXP,0),"^")_" RELEASED"
+3 IF $$STATUS^PSOBPSUT(RXP)]""
IF $$WINFILL^PSODISPS(RXP)
DO SIGMSG^PSODISPS
+4 QUIT
QTY SET PSOCPN=$PIECE(^PSRX(RXP,0),"^",2)
SET QDRUG=$PIECE(^PSRX(RXP,0),"^",6)
KILL LBLP
+1 if $PIECE($GET(^PSRX(RXP,$PIECE(XTYPE,"^"),$PIECE(XTYPE,"^",2),0)),"^")'<PSIN
Begin DoDot:1
+2 SET RXFD=$EXTRACT($PIECE(^PSRX(RXP,$PIECE(XTYPE,"^"),$PIECE(XTYPE,"^",2),0),"^"),1,7)
SET SUPN=$ORDER(^PS(52.5,"B",RXP,0))
IF SUPN
IF $DATA(^PS(52.5,"C",RXFD,SUPN))
IF $GET(^PS(52.5,SUPN,"P"))'=1
SET ISUF=1
DO UPDATE
QUIT
+3 IF $PIECE(^PSRX(RXP,$PIECE(XTYPE,"^"),$PIECE(XTYPE,"^",2),0),"^",$SELECT($PIECE($GET(XTYPE),"^"):18,1:19))]""!($PIECE(^(0),"^",16))
KILL IFN
QUIT
+4 ;
+5 FOR LBL=0:0
SET LBL=$ORDER(^PSRX(RXP,"L",LBL))
if 'LBL
QUIT
IF $PIECE(^PSRX(RXP,"L",LBL,0),"^",2)=$SELECT('$PIECE(XTYPE,"^"):(99-$PIECE(XTYPE,"^",2)),1:$PIECE(XTYPE,"^",2))
SET LBLP=1
+6 if '$GET(LBLP)
QUIT
DO ASK
if $GET(PSOUT)
QUIT
+7 ;
+8 ; - Checking for OPEN/UNRESOLVED 3rd. Party Payer Rejects / NDC Editing
+9 IF XTYPE
IF $$MANREL^PSOBPSUT(RXP,$PIECE(XTYPE,"^",2))="^"
KILL LBLP
QUIT
+10 ;
+11 SET IFN=$PIECE(XTYPE,"^",2)
if $GET(^PSDRUG(QDRUG,660.1))]""
SET QTY=$PIECE(^PSRX(RXP,$PIECE(XTYPE,"^"),$PIECE(XTYPE,"^",2),0),"^",4)
SET ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY
+12 DO NOW^%DTC
SET DIE="^PSRX("_RXP_","""_$PIECE(XTYPE,"^")_""","
+13 SET DA(1)=RXP
SET DA=$PIECE(XTYPE,"^",2)
+14 SET DR=$SELECT(+XTYPE:17,1:8)_"///"_%_";"_$SELECT(+XTYPE:4,1:.05)_"////"_PSRH
+15 DO ^DIE
KILL DIE,DR,DA
+16 KILL PSODISPP
if '$PIECE($GET(XTYPE),"^")
SET PSODISPP=1
DO EN^PSOHLSN1(RXP,"ZD")
KILL PSODISPP
+17 ;
+18 ; - Notifying IB through ECME of the Rx being released
+19 IF XTYPE
DO IBSEND^PSOBPSUT(RXP,$PIECE(XTYPE,"^",2))
+20 ;
+21 if +XTYPE
KILL ^PSRX("ACP",$PIECE($GET(^PSRX(RXP,0)),"^",2),$PIECE($GET(^PSRX(RXP,1,$PIECE(XTYPE,"^",2),0)),"^"),$PIECE(XTYPE,"^",2),RXP)
+22 IF +XTYPE
IF $GET(IFN)
IF '$GET(ISUF)
SET PSOCPRX=$PIECE(^PSRX(RXP,0),"^")
SET YY=$PIECE(XTYPE,"^",2)
DO CP^PSOCP
End DoDot:1
KILL ISUF,LBLP
if $GET(PSOUT)
GOTO EX
+23 if $GET(IFN)
WRITE !!?7,"PRESCRIPTION NUMBER "_$PIECE(^PSRX(RXP,0),"^")_$SELECT('+$GET(XTYPE):" Partial Fill",1:" REFILL")_" #"_$PIECE(XTYPE,"^",2)_" RELEASED"
+24 if '$GET(IFN)
WRITE !!?7,$SELECT(+$GET(XTYPE):"REFILL",1:"PARTIAL")_" #"_$PIECE(XTYPE,"^",2)_" NOT RELEASED"
+25 IF $GET(IFN)
IF $$STATUS^PSOBPSUT(RXP)]""
IF $$WINFILL^PSODISPS(RXP)
DO SIGMSG^PSODISPS
+26 KILL IFN
+27 QUIT
ASK ;confirm
+1 WRITE !
KILL DIR
SET DIR(0)="SA^1:YES;0:NO"
SET DIR("B")="Yes"
SET DIR("A",1)="Are You sure you want to release "_$SELECT($GET(XTYPE)']"":"Original ",$PIECE(XTYPE,"^")=1:"Re",1:"Partial ")_"fill"_$SELECT($PIECE(XTYPE,"^",2):" #"_$PIECE(XTYPE,"^",2),1:"")
+2 SET DIR("A")="for Prescription #"_$PIECE(^PSRX(RXP,0),"^")_": "
DO ^DIR
KILL DIR
+3 if 'Y!($DATA(DIRUT))
SET PSOUT=1
+4 ;bingo board call
+5 IF Y
IF $GET(XTYPE)=""
IF $PIECE(^PSRX(RXP,0),"^",11)["W"
SET BINGRO="W"
SET BINGNAM=$PIECE(^PSRX(RXP,0),"^",2)
SET BINGDIV=$PIECE(^PSRX(RXP,2),"^",9)
+6 IF Y
IF $GET(XTYPE)["P"
IF $PIECE($GET(^PSRX(RXP,"P",$PIECE(XTYPE,"^",2),0)),"^",2)["W"
SET BINGRPR="W"
SET BNGPDV=$PIECE(^PSRX(RXP,"P",$PIECE(XTYPE,"^",2),0),"^",9)
SET BINGNAM=$PIECE($GET(^PSRX(RXP,0)),"^",2)
+7 IF Y
IF +$GET(XTYPE)=1
IF $PIECE($GET(^PSRX(RXP,1,$PIECE(XTYPE,"^",2),0)),"^",2)["W"
SET BINGRPR="W"
SET BNGRDV=$PIECE(^PSRX(RXP,1,$PIECE(XTYPE,"^",2),0),"^",9)
SET BINGNAM=$PIECE($GET(^PSRX(RXP,0)),"^",2)
+8 IF $DATA(DISGROUP)
IF ($DATA(BINGDIV)!$DATA(BNGPDV)!$DATA(BNGRDV))
IF ($DATA(BINGRO)!$DATA(BINGRPR))
DO REL^PSOBING1
KILL BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
+9 QUIT
