- PSODISP ;BIR/SAB,PWC - MANUAL BARCODE RELEASE FUNCTION ;Nov 23, 2021@09:00
- ;;7.0;OUTPATIENT PHARMACY;**15,71,131,156,185,148,247,200,385,391,441,703**;DEC 1997;Build 16
- ; Reference to $$SERV^IBARX1 in ICR #2245
- ; Reference to ^PSD(58.8 in ICR #1036
- ; Reference to ^PS(55 in ICR #2228
- ; Reference to ^PSDRUG in ICR #221
- ; Reference to ^PSDRUG("AQ" in ICR #3165
- ; Reference to ^XTMP("PSA" in ICR #1036
- ; Reference to ^PS(59.7 in ICR #694
- ; Reference to ^DIC(19.2 in ICR #1064
- ;
- AC K CX,PSODA,PSODT,PSRH,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSOPID
- N PSOPARTIAL
- K ^UTILITY($J,"PSOHL") S PSOPID=1
- I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,?5,"Site Parameters must be defined to use the Release option!",! G EXIT
- S Y=$G(^PS(59,PSOSITE,"IB")),PSOIBSS=$$SERV^IBARX1(+Y) I 'PSOIBSS D IBSSR^PSOUTL I 'PSOIBFL D G EXIT
- .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!",!
- AC1 W !! S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2)
- S DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))",DIC("A")="Enter PHARMACIST: ",DIC="^VA(200,",DIC(0)="QEAM" D ^DIC G:"^"[X EXIT K DIC G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!(Y=-1) EXIT S PSRH=+Y
- ;check for Drug Acct background job K8 & K7.1
- S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19.2 D ^DIC I Y=-1 K DIC,X,Y G BC
- I $P($G(Y(0)),U,2)>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT G BC
- S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19 D ^DIC K DIC,X G:Y=-1 BC
- K DIQ,PSA S DA=+Y,DIC=19,DIQ="PSA",DR=200,DIQ(0)="IN" D EN^DIQ1
- I '$D(PSA(19,DA,200,"I")) K DIC,DA,X,Y,DIQ G BC
- I PSA(19,DA,200,"I")>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT
- K PSA,DIC,DA,X,Y,DIQ
- BC ;
- K MAN I $G(RXP),$D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
- Q:$G(POERR) W !! K CMOP,ISUF,DIR,LBL,LBLP S DIR("A")="Enter/Wand PRESCRIPTION number",DIR("?")="^D HELP^PSODISP",DIR(0)="FO" D ^DIR
- I $D(DIRUT)!($D(DTOUT))!($D(DUOUT)) K DIRUT,DTOUT,DUOUT G AC1
- I X'["-" D BCI W:'$G(RXP) !,"INVALID PRESCRIPTION NUMBER" G:'$G(RXP) BC S MAN=1 G BC1
- I X["-",$P(X,"-")'=$P($$SITE^VASITE(),"^",3) W !?7,$C(7),$C(7)," INVALID STATION NUMBER !!",$C(7),$C(7),! G BC
- I X["-" S RXP=$P(X,"-",2) I '$D(^PSRX(+$G(RXP),0))!($G(RXP)']"") W !?7,$C(7),$C(7),$C(7)," NON-EXISTENT PRESCRIPTION" G BC
- I $D(^PSRX(RXP,0)) D G BC1
- .S PSOLOUD=1 D:$P($G(^PS(55,+$P(^PSRX(+RXP,0),"^",2),0)),"^",6)'=2 EN^PSOHLUP($P(^PSRX(+RXP,0),"^",2)) K PSOLOUD
- W !?7,$C(7),$C(7),$C(7)," IMPROPER BARCODE FORMAT" G BC
- BC1 ;
- D ICN^PSODPT(+$P(^PSRX(RXP,0),"^",2))
- I +$G(^PSRX(+RXP,"PARK")) D Q:$G(POERR) G BC ;441 PAPI
- .I $G(SPEED) W !!?7,$C(7),$C(7),"Rx# "_$P(^PSRX(RXP,0),"^") S PSOLIST=4
- .W !!,?7,"UNABLE TO RELEASE - THIS ORDER MUST BE UNPARKED BEFORE ACTING ON IT"
- I +$P($G(^PSRX(+RXP,"STA")),"^")=13!(+$P($G(^PSRX(+RXP,0)),"^",2)=0) W !?7,$C(7),$C(7)," PRESCRIPTION IS A DELETED PRESCRIPTION NUMBER" Q:$G(POERR) D DCHK G BC
- I +$P($G(^PSRX(+RXP,"STA")),"^"),$S($P(^("STA"),"^")=2:0,$P(^("STA"),"^")=5:0,$P(^("STA"),"^")=11:0,$P(^("STA"),"^")=12:0,$P(^("STA"),"^")=14:0,$P(^("STA"),"^")=15:0,1:1) D STAT^PSODISPS Q:$G(POERR) D DCHK G BC
- ;drug stocked in Drug Acct Location?
- S PSODA(1)=$S($D(^PSD(58.8,+$O(^PSD(58.8,"AOP",+PSOSITE,0)),1,+$P(^PSRX(RXP,0),U,6))):1,1:0)
- I $P(^PSRX(RXP,2),"^",13) S Y=$P(^PSRX(RXP,2),"^",13) X ^DD("DD") S OUT=1 D K OUT Q:$G(POERR) D DCHK G BC
- .W !!?7,$C(7),$C(7),$S($G(SPEED):"Rx# "_$P(^PSRX(RXP,0),"^"),1:"Original prescription")_" was last released on "_Y,!?7,"Checking for unreleased refills/partials " D REF
- BATCH ;
- I $P(^PSRX(RXP,2),"^",15),'$P(^(2),"^",14) S RESK=$P(^(2),"^",15) W !!?5,"Rx# "_$P(^PSRX(RXP,0),"^")_" Original Fill returned to stock on "_$E(RESK,4,5)_"/"_$E(RESK,6,7)_"/"_$E(RESK,2,3),! G REF
- ;flag to determine if site is running HL7 v.2.4 Dispense Machines
- N PSODISP S PSODISP=$$GET1^DIQ(59,PSOSITE_",",105,"I")
- S PSOCPN=$P(^PSRX(RXP,0),"^",2),QTY=$P($G(^PSRX(RXP,0)),"^",7),QDRUG=$P(^PSRX(RXP,0),"^",6)
- ;original
- I '$P($G(^PSRX(RXP,2)),"^",13),+$P($G(^(2)),"^",2)'<PSIN S RXFD=$P(^(2),"^",2) D D:$G(LBLP) UPDATE I $G(ISUF) D UPDATE G REF
- .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,'$P($G(^(0)),"^",5) S ISUF=1 Q
- .I $D(^PSDRUG("AQ",QDRUG)) K CMOP D OREL^PSOCMOPB(RXP) K CMOP I $G(ISUF) K ISUF,CMOP 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),$P(^(0),"^",3)'["INTERACTION" S LBLP=1
- .D CHKADDR^PSODISPS(RXP)
- .Q:'$G(LBLP)
- .;
- .; - Checking for OPEN/UNRESOLVED 3rd. Party Payer Rejects / NDC Editing
- .I $$MANREL^PSOBPSUT(RXP,0,$G(PSOPID))="^" K LBLP Q
- .;
- .S:$D(^PSDRUG(QDRUG,660.1)) ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY
- .D NOW^%DTC S DIE="^PSRX(",DA=RXP,DR="31///"_%_";23////"_PSRH_";32.1///@;32.2///@",PSODT=% D ^DIE K DIE,DR,DA,LBL
- .;
- .; - Notifying IB through ECME of the Rx has been released
- .D IBSEND^PSOBPSUT(RXP,0)
- .;
- .D EN^PSOHLSN1(RXP,"ZD")
- .;if appropriate update ^XTMP("PSA", for Drug Acct
- .I $G(PSODA),$G(PSODA(1)),'$D(^PSRX("AR",+PSODT,+RXP,0)) S ^XTMP("PSA",+PSOSITE,+QDRUG,+DT)=$G(^XTMP("PSA",+PSOSITE,+QDRUG,+DT))+QTY
- REF ;release refills and partials
- K LBLP,IFN F XTYPE=1,"P" K IFN D QTY^PSODISPS
- Q:+$G(OUT)!($G(POERR)) D DCHK
- G BC
- UPDATE I $G(ISUF) W $C(7),!!?7,"Prescription "_$P(^PSRX(RXP,0),"^")_" - Original Fill on Suspense !",!,$C(7) Q
- N BFILL S BFILL=0
- 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),'$G(PSOPARTIAL) D SIGMSG^PSODISPS
- ;initialize bingo board variables
- I $G(LBLP),$P(^PSRX(RXP,0),"^",11)["W" S BINGRO="W",BINGNAM=$P(^PSRX(RXP,0),"^",2),BINGDIV=$P(^PSRX(RXP,2),"^",9)
- I $G(PSODISP)=2.4 D ;HL7 v2.4 dispensing machines
- . F I=0:0 S SUB=$O(^PSRX(RXP,"A",I)) Q:'I I $P(^PSRX(RXP,"A",I,0),"^",2)="N" D XMIT ;only send release dt/time transmission for dispensed orders
- Q
- ;
- EXIT ;
- K OUT,RX2,RXFD,RESK,ISUF,SUPN,%,DIC,IFN,J,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,PSOIBSS,PSOIBFL,PSOIBLP,PSOIBST,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSRH,XX,Y,PSIN,MAN,PSODISP,SUB
- Q
- ;
- GETFILL ; get the fill number
- S NFLD=0,UU="" F S UU=$O(^PSRX(+RXP,1,UU)) Q:UU="" S:$D(^PSRX(+RXP,1,UU,0)) NFLD=NFLD+1
- Q
- ;
- HELP W !!,"Wand the barcode number of the prescription or manually key in",!,"the number below the barcode or the prescription number.",!,"The barcode number should be of the format - 'NNN-NNNNNNN'"
- Q
- ;
- BCI S RXP=0
- RXP S RXP=$O(^PSRX("B",X,RXP)) I $P($G(^PSRX(+RXP,"STA")),"^")=13 G RXP ;GET RECORD NUMBER FROM SCRIPT NUMBER
- Q
- ;
- DCHK ;checks for duplicate
- Q:'$G(MAN)
- I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
- S RXP=$O(^PSRX("B",$P(^PSRX(RXP,0),"^"),RXP)) I 'RXP K POERR,MAN Q
- I $P($G(^PSRX(RXP,"STA")),"^")=13 G DCHK
- I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
- W !!,"Duplicate Rx # "_$P(^PSRX(RXP,0),"^")_" found."
- S POERR=1 D BC1^PSODISP
- I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
- G DCHK
- Q
- ;
- XMIT D NOW^%DTC S PSODTM=%
- S IDGN=$P(^PSRX(+RXP,0),"^",6)
- K ^UTILITY($J,"PSOHL")
- S ^UTILITY($J,"PSOHL",1)=+RXP_"^"_IDGN_"^"_PSODTM_"^"_+$G(PDUZ)_"^0^^PSO DISP^^^"_FP_"^"_FPN
- S ZTRTN="INIT^PSORELDT",ZTDESC="EXTERNAL INTERFACE FOR RELEASE DATE/TIME",ZTIO="",ZTDTH=$H,ZTSAVE("^UTILITY($J,""PSOHL"",")="",ZTSAVE("PSOSITE")="",ZTSAVE("RXP")="",ZTSAVE("PSOLAP")="" D ^%ZTLOAD K ^UTILITY($J,"PSOHL")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODISP 8024 printed Feb 18, 2025@23:53:33 Page 2
- PSODISP ;BIR/SAB,PWC - MANUAL BARCODE RELEASE FUNCTION ;Nov 23, 2021@09:00
- +1 ;;7.0;OUTPATIENT PHARMACY;**15,71,131,156,185,148,247,200,385,391,441,703**;DEC 1997;Build 16
- +2 ; Reference to $$SERV^IBARX1 in ICR #2245
- +3 ; Reference to ^PSD(58.8 in ICR #1036
- +4 ; Reference to ^PS(55 in ICR #2228
- +5 ; Reference to ^PSDRUG in ICR #221
- +6 ; Reference to ^PSDRUG("AQ" in ICR #3165
- +7 ; Reference to ^XTMP("PSA" in ICR #1036
- +8 ; Reference to ^PS(59.7 in ICR #694
- +9 ; Reference to ^DIC(19.2 in ICR #1064
- +10 ;
- AC KILL CX,PSODA,PSODT,PSRH,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSOPID
- +1 NEW PSOPARTIAL
- +2 KILL ^UTILITY($JOB,"PSOHL")
- SET PSOPID=1
- +3 IF '$DATA(PSOPAR)
- DO ^PSOLSET
- IF '$DATA(PSOPAR)
- WRITE $CHAR(7),!!,?5,"Site Parameters must be defined to use the Release option!",!
- GOTO EXIT
- +4 SET Y=$GET(^PS(59,PSOSITE,"IB"))
- SET PSOIBSS=$$SERV^IBARX1(+Y)
- IF 'PSOIBSS
- DO IBSSR^PSOUTL
- IF 'PSOIBFL
- Begin DoDot:1
- +5 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 EXIT
- AC1 WRITE !!
- SET PSIN=+$PIECE($GET(^PS(59.7,1,49.99)),"^",2)
- +1 SET DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))"
- SET DIC("A")="Enter PHARMACIST: "
- SET DIC="^VA(200,"
- SET DIC(0)="QEAM"
- DO ^DIC
- if "^"[X
- GOTO EXIT
- KILL DIC
- if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!(Y=-1)
- GOTO EXIT
- SET PSRH=+Y
- +2 ;check for Drug Acct background job K8 & K7.1
- +3 SET X="PSA IV ALL LOCATIONS"
- SET DIC(0)="MZ"
- SET DIC=19.2
- DO ^DIC
- IF Y=-1
- KILL DIC,X,Y
- GOTO BC
- +4 IF $PIECE($GET(Y(0)),U,2)>DT
- SET PSODA=1
- if '$PIECE($GET(^XTMP("PSA",0)),U,2)
- SET $PIECE(^(0),U,2)=DT
- GOTO BC
- +5 SET X="PSA IV ALL LOCATIONS"
- SET DIC(0)="MZ"
- SET DIC=19
- DO ^DIC
- KILL DIC,X
- if Y=-1
- GOTO BC
- +6 KILL DIQ,PSA
- SET DA=+Y
- SET DIC=19
- SET DIQ="PSA"
- SET DR=200
- SET DIQ(0)="IN"
- DO EN^DIQ1
- +7 IF '$DATA(PSA(19,DA,200,"I"))
- KILL DIC,DA,X,Y,DIQ
- GOTO BC
- +8 IF PSA(19,DA,200,"I")>DT
- SET PSODA=1
- if '$PIECE($GET(^XTMP("PSA",0)),U,2)
- SET $PIECE(^(0),U,2)=DT
- +9 KILL PSA,DIC,DA,X,Y,DIQ
- BC ;
- +1 KILL MAN
- IF $GET(RXP)
- IF $DATA(DISGROUP)
- IF $DATA(BINGNAM)
- IF ($DATA(BINGDIV)!$DATA(BNGPDV)!$DATA(BNGRDV))
- IF ($DATA(BINGRO)!$DATA(BINGRPR))
- DO REL^PSOBING1
- KILL BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
- +2 if $GET(POERR)
- QUIT
- WRITE !!
- KILL CMOP,ISUF,DIR,LBL,LBLP
- SET DIR("A")="Enter/Wand PRESCRIPTION number"
- SET DIR("?")="^D HELP^PSODISP"
- SET DIR(0)="FO"
- DO ^DIR
- +3 IF $DATA(DIRUT)!($DATA(DTOUT))!($DATA(DUOUT))
- KILL DIRUT,DTOUT,DUOUT
- GOTO AC1
- +4 IF X'["-"
- DO BCI
- if '$GET(RXP)
- WRITE !,"INVALID PRESCRIPTION NUMBER"
- if '$GET(RXP)
- GOTO BC
- SET MAN=1
- GOTO BC1
- +5 IF X["-"
- IF $PIECE(X,"-")'=$PIECE($$SITE^VASITE(),"^",3)
- WRITE !?7,$CHAR(7),$CHAR(7)," INVALID STATION NUMBER !!",$CHAR(7),$CHAR(7),!
- GOTO BC
- +6 IF X["-"
- SET RXP=$PIECE(X,"-",2)
- IF '$DATA(^PSRX(+$GET(RXP),0))!($GET(RXP)']"")
- WRITE !?7,$CHAR(7),$CHAR(7),$CHAR(7)," NON-EXISTENT PRESCRIPTION"
- GOTO BC
- +7 IF $DATA(^PSRX(RXP,0))
- Begin DoDot:1
- +8 SET PSOLOUD=1
- if $PIECE($GET(^PS(55,+$PIECE(^PSRX(+RXP,0),"^",2),0)),"^",6)'=2
- DO EN^PSOHLUP($PIECE(^PSRX(+RXP,0),"^",2))
- KILL PSOLOUD
- End DoDot:1
- GOTO BC1
- +9 WRITE !?7,$CHAR(7),$CHAR(7),$CHAR(7)," IMPROPER BARCODE FORMAT"
- GOTO BC
- BC1 ;
- +1 DO ICN^PSODPT(+$PIECE(^PSRX(RXP,0),"^",2))
- +2 ;441 PAPI
- IF +$GET(^PSRX(+RXP,"PARK"))
- Begin DoDot:1
- +3 IF $GET(SPEED)
- WRITE !!?7,$CHAR(7),$CHAR(7),"Rx# "_$PIECE(^PSRX(RXP,0),"^")
- SET PSOLIST=4
- +4 WRITE !!,?7,"UNABLE TO RELEASE - THIS ORDER MUST BE UNPARKED BEFORE ACTING ON IT"
- End DoDot:1
- if $GET(POERR)
- QUIT
- GOTO BC
- +5 IF +$PIECE($GET(^PSRX(+RXP,"STA")),"^")=13!(+$PIECE($GET(^PSRX(+RXP,0)),"^",2)=0)
- WRITE !?7,$CHAR(7),$CHAR(7)," PRESCRIPTION IS A DELETED PRESCRIPTION NUMBER"
- if $GET(POERR)
- QUIT
- DO DCHK
- GOTO BC
- +6 IF +$PIECE($GET(^PSRX(+RXP,"STA")),"^")
- IF $SELECT($PIECE(^("STA"),"^")=2:0,$PIECE(^("STA"),"^")=5:0,$PIECE(^("STA"),"^")=11:0,$PIECE(^("STA"),"^")=12:0,$PIECE(^("STA"),"^")=14:0,$PIECE(^("STA"),"^")=15:0,1:1)
- DO STAT^PSODISPS
- if $GET(POERR)
- QUIT
- DO DCHK
- GOTO BC
- +7 ;drug stocked in Drug Acct Location?
- +8 SET PSODA(1)=$SELECT($DATA(^PSD(58.8,+$ORDER(^PSD(58.8,"AOP",+PSOSITE,0)),1,+$PIECE(^PSRX(RXP,0),U,6))):1,1:0)
- +9 IF $PIECE(^PSRX(RXP,2),"^",13)
- SET Y=$PIECE(^PSRX(RXP,2),"^",13)
- XECUTE ^DD("DD")
- SET OUT=1
- Begin DoDot:1
- +10 WRITE !!?7,$CHAR(7),$CHAR(7),$SELECT($GET(SPEED):"Rx# "_$PIECE(^PSRX(RXP,0),"^"),1:"Original prescription")_" was last released on "_Y,!?7,"Checking for unreleased refills/partials "
- DO REF
- End DoDot:1
- KILL OUT
- if $GET(POERR)
- QUIT
- DO DCHK
- GOTO BC
- BATCH ;
- +1 IF $PIECE(^PSRX(RXP,2),"^",15)
- IF '$PIECE(^(2),"^",14)
- SET RESK=$PIECE(^(2),"^",15)
- WRITE !!?5,"Rx# "_$PIECE(^PSRX(RXP,0),"^")_" Original Fill returned to stock on "_$EXTRACT(RESK,4,5)_"/"_$EXTRACT(RESK,6,7)_"/"_$EXTRACT(RESK,2,3),!
- GOTO REF
- +2 ;flag to determine if site is running HL7 v.2.4 Dispense Machines
- +3 NEW PSODISP
- SET PSODISP=$$GET1^DIQ(59,PSOSITE_",",105,"I")
- +4 SET PSOCPN=$PIECE(^PSRX(RXP,0),"^",2)
- SET QTY=$PIECE($GET(^PSRX(RXP,0)),"^",7)
- SET QDRUG=$PIECE(^PSRX(RXP,0),"^",6)
- +5 ;original
- +6 IF '$PIECE($GET(^PSRX(RXP,2)),"^",13)
- IF +$PIECE($GET(^(2)),"^",2)'<PSIN
- SET RXFD=$PIECE(^(2),"^",2)
- Begin DoDot: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
- IF '$PIECE($GET(^(0)),"^",5)
- SET ISUF=1
- QUIT
- +8 IF $DATA(^PSDRUG("AQ",QDRUG))
- KILL CMOP
- DO OREL^PSOCMOPB(RXP)
- KILL CMOP
- IF $GET(ISUF)
- KILL ISUF,CMOP
- QUIT
- +9 ;
- +10 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)
- IF $PIECE(^(0),"^",3)'["INTERACTION"
- SET LBLP=1
- +11 DO CHKADDR^PSODISPS(RXP)
- +12 if '$GET(LBLP)
- QUIT
- +13 ;
- +14 ; - Checking for OPEN/UNRESOLVED 3rd. Party Payer Rejects / NDC Editing
- +15 IF $$MANREL^PSOBPSUT(RXP,0,$GET(PSOPID))="^"
- KILL LBLP
- QUIT
- +16 ;
- +17 if $DATA(^PSDRUG(QDRUG,660.1))
- SET ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY
- +18 DO NOW^%DTC
- SET DIE="^PSRX("
- SET DA=RXP
- SET DR="31///"_%_";23////"_PSRH_";32.1///@;32.2///@"
- SET PSODT=%
- DO ^DIE
- KILL DIE,DR,DA,LBL
- +19 ;
- +20 ; - Notifying IB through ECME of the Rx has been released
- +21 DO IBSEND^PSOBPSUT(RXP,0)
- +22 ;
- +23 DO EN^PSOHLSN1(RXP,"ZD")
- +24 ;if appropriate update ^XTMP("PSA", for Drug Acct
- +25 IF $GET(PSODA)
- IF $GET(PSODA(1))
- IF '$DATA(^PSRX("AR",+PSODT,+RXP,0))
- SET ^XTMP("PSA",+PSOSITE,+QDRUG,+DT)=$GET(^XTMP("PSA",+PSOSITE,+QDRUG,+DT))+QTY
- End DoDot:1
- if $GET(LBLP)
- DO UPDATE
- IF $GET(ISUF)
- DO UPDATE
- GOTO REF
- REF ;release refills and partials
- +1 KILL LBLP,IFN
- FOR XTYPE=1,"P"
- KILL IFN
- DO QTY^PSODISPS
- +2 if +$GET(OUT)!($GET(POERR))
- QUIT
- DO DCHK
- +3 GOTO BC
- UPDATE IF $GET(ISUF)
- WRITE $CHAR(7),!!?7,"Prescription "_$PIECE(^PSRX(RXP,0),"^")_" - Original Fill on Suspense !",!,$CHAR(7)
- QUIT
- +1 NEW BFILL
- SET BFILL=0
- +2 SET PSOCPRX=$PIECE(^PSRX(RXP,0),"^")
- DO CP^PSOCP
- +3 WRITE !?7,"Prescription Number "_$PIECE(^PSRX(RXP,0),"^")_" Released"
- +4 IF $$STATUS^PSOBPSUT(RXP)]""
- IF $$WINFILL^PSODISPS(RXP)
- IF '$GET(PSOPARTIAL)
- DO SIGMSG^PSODISPS
- +5 ;initialize bingo board variables
- +6 IF $GET(LBLP)
- IF $PIECE(^PSRX(RXP,0),"^",11)["W"
- SET BINGRO="W"
- SET BINGNAM=$PIECE(^PSRX(RXP,0),"^",2)
- SET BINGDIV=$PIECE(^PSRX(RXP,2),"^",9)
- +7 ;HL7 v2.4 dispensing machines
- IF $GET(PSODISP)=2.4
- Begin DoDot:1
- +8 ;only send release dt/time transmission for dispensed orders
- FOR I=0:0
- SET SUB=$ORDER(^PSRX(RXP,"A",I))
- if 'I
- QUIT
- IF $PIECE(^PSRX(RXP,"A",I,0),"^",2)="N"
- DO XMIT
- End DoDot:1
- +9 QUIT
- +10 ;
- EXIT ;
- +1 KILL OUT,RX2,RXFD,RESK,ISUF,SUPN,%,DIC,IFN,J,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,PSOIBSS,PSOIBFL,PSOIBLP,PSOIBST,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSRH,XX,Y,PSIN,MAN,PSODISP,SUB
- +2 QUIT
- +3 ;
- GETFILL ; get the fill number
- +1 SET NFLD=0
- SET UU=""
- FOR
- SET UU=$ORDER(^PSRX(+RXP,1,UU))
- if UU=""
- QUIT
- if $DATA(^PSRX(+RXP,1,UU,0))
- SET NFLD=NFLD+1
- +2 QUIT
- +3 ;
- HELP WRITE !!,"Wand the barcode number of the prescription or manually key in",!,"the number below the barcode or the prescription number.",!,"The barcode number should be of the format - 'NNN-NNNNNNN'"
- +1 QUIT
- +2 ;
- BCI SET RXP=0
- RXP ;GET RECORD NUMBER FROM SCRIPT NUMBER
- SET RXP=$ORDER(^PSRX("B",X,RXP))
- IF $PIECE($GET(^PSRX(+RXP,"STA")),"^")=13
- GOTO RXP
- +1 QUIT
- +2 ;
- DCHK ;checks for duplicate
- +1 if '$GET(MAN)
- QUIT
- +2 IF $DATA(DISGROUP)
- IF $DATA(BINGNAM)
- IF ($DATA(BINGDIV)!$DATA(BNGPDV)!$DATA(BNGRDV))
- IF ($DATA(BINGRO)!$DATA(BINGRPR))
- DO REL^PSOBING1
- KILL BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
- +3 SET RXP=$ORDER(^PSRX("B",$PIECE(^PSRX(RXP,0),"^"),RXP))
- IF 'RXP
- KILL POERR,MAN
- QUIT
- +4 IF $PIECE($GET(^PSRX(RXP,"STA")),"^")=13
- GOTO DCHK
- +5 IF $DATA(DISGROUP)
- IF $DATA(BINGNAM)
- IF ($DATA(BINGDIV)!$DATA(BNGPDV)!$DATA(BNGRDV))
- IF ($DATA(BINGRO)!$DATA(BINGRPR))
- DO REL^PSOBING1
- KILL BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
- +6 WRITE !!,"Duplicate Rx # "_$PIECE(^PSRX(RXP,0),"^")_" found."
- +7 SET POERR=1
- DO BC1^PSODISP
- +8 IF $DATA(DISGROUP)
- IF $DATA(BINGNAM)
- IF ($DATA(BINGDIV)!$DATA(BNGPDV)!$DATA(BNGRDV))
- IF ($DATA(BINGRO)!$DATA(BINGRPR))
- DO REL^PSOBING1
- KILL BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
- +9 GOTO DCHK
- +10 QUIT
- +11 ;
- XMIT DO NOW^%DTC
- SET PSODTM=%
- +1 SET IDGN=$PIECE(^PSRX(+RXP,0),"^",6)
- +2 KILL ^UTILITY($JOB,"PSOHL")
- +3 SET ^UTILITY($JOB,"PSOHL",1)=+RXP_"^"_IDGN_"^"_PSODTM_"^"_+$GET(PDUZ)_"^0^^PSO DISP^^^"_FP_"^"_FPN
- +4 SET ZTRTN="INIT^PSORELDT"
- SET ZTDESC="EXTERNAL INTERFACE FOR RELEASE DATE/TIME"
- SET ZTIO=""
- SET ZTDTH=$HOROLOG
- SET ZTSAVE("^UTILITY($J,""PSOHL"",")=""
- SET ZTSAVE("PSOSITE")=""
- SET ZTSAVE("RXP")=""
- SET ZTSAVE("PSOLAP")=""
- DO ^%ZTLOAD
- KILL ^UTILITY($JOB,"PSOHL")
- +5 QUIT
