- 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 Feb 18, 2025@23:52:34 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