PSODISP3 ;ISC-BHAM/SAB - rx speed release ;08/30/95 10:24
;;7.0;OUTPATIENT PHARMACY;**15,13,148,385**;DEC 1997;Build 27
;External reference ^PS(59.7 supported by DBIA 694
;External reference ^XTMP("PSA" supported by DBIA 1036
;External reference $$SERV^IBARX supported by DBIA 2245
SEL N VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
K ^UTILITY($J,"PSOPCE"),QFLG,PSOFDR,DIR,DUOUT,DIRUT S DIR("A")="Select Orders by number",DIR(0)="LO^1:"_PSOCNT D ^DIR I $D(DTOUT)!($D(DUOUT)) K DIR,DIRUT,DTOUT,DUOUT S VALMBCK="" Q
K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT I +Y S (SPEED,PSOOELSE,PSOPCECT)=1 D FULL^VALM1 S LST=Y D
. D ASK Q:$G(QFLG) S PSOLIST=0,PSOPID=1
. F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']"" D
. . K ISUF,IFN S ORN=$P(LST,",",ORD)
. . S RXP=$P(PSOLST($P(LST,",",ORD)),"^",2),POERR=1
. . D:+PSOLST(ORN)=52 FULL^VALM1,BC1^PSODISP W ! S PSOLIST=PSOLIST+1
. . I PSOLIST=5 D
. . . K DIR,DIRUT S DIR(0)="E",DIR("A",1)="",DIR("A")="Press Return to Continue"
. . . W ! D ^DIR K DIR,DIRUT S PSOLIST=0
. I $D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) N TM,TM1 D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV D
. . K DIR,DIRUT S DIR(0)="E",DIR("A",1)="",DIR("A")="Press Return to Continue"
. . W ! D ^DIR K DIR,DIRUT
. I $G(PSORLS),$$STATUS^PSOBPSUT(RXP)]"",$$WINFILL^PSODISPS(RXP) D SIGMSG^PSODISPS K PSORLS
I '$G(PSOOELSE) S VALMBCK="" Q
S VALMBCK="R",PSORXED=1 D BLD^PSOORUT1
EX K SPEED,PSOPCECT,PSOOELSE,QFLG,PSORXED,OUT,RX2,RXFD,RESK,ISUF,SUPN,%,DIC,IFN,J,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,ORD,LST,POERR,PSOLIST
K REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,PSOIBSS,PSOIBFL,PSOIBLP,PSOIBST,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSRH,XX,Y,PSIN
Q
ASK ;
I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) S VALMSG="Site Parameters must be defined to use the Release option!",VALMBCK="R",QFLG=1 Q
S VALMBCK="Q",Y=$G(^PS(59,PSOSITE,"IB")),PSOIBSS=$$SERV^IBARX1(+Y) I 'PSOIBSS D IBSSR^PSOUTL I 'PSOIBFL D S VALMBCK="R",QFLG=1 Q
.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!",! H 3
W !! S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2)
RPH S DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))",DIC("A")="Enter PHARMACIST: ",DIC="^VA(200,",DIC(0)="QEAM" D ^DIC I "^"[X S QFLG=1 Q
G:Y=-1 RPH K DIC I $D(DIRUT) S QFLG=1 Q
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 Q
I $P($G(Y(0)),U,2)>DT S PSODA=1 S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT Q
S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19 D ^DIC K DIC,X Q:Y=-1
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 Q
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODISP3 2938 printed Dec 13, 2024@02:27:09 Page 2
PSODISP3 ;ISC-BHAM/SAB - rx speed release ;08/30/95 10:24
+1 ;;7.0;OUTPATIENT PHARMACY;**15,13,148,385**;DEC 1997;Build 27
+2 ;External reference ^PS(59.7 supported by DBIA 694
+3 ;External reference ^XTMP("PSA" supported by DBIA 1036
+4 ;External reference $$SERV^IBARX supported by DBIA 2245
SEL NEW VALMCNT
IF '$GET(PSOCNT)
SET VALMSG="This patient has no Prescriptions!"
SET VALMBCK=""
QUIT
+1 KILL ^UTILITY($JOB,"PSOPCE"),QFLG,PSOFDR,DIR,DUOUT,DIRUT
SET DIR("A")="Select Orders by number"
SET DIR(0)="LO^1:"_PSOCNT
DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
KILL DIR,DIRUT,DTOUT,DUOUT
SET VALMBCK=""
QUIT
+2 KILL DIR,DIRUT,DTOUT,PSOOELSE,DTOUT
IF +Y
SET (SPEED,PSOOELSE,PSOPCECT)=1
DO FULL^VALM1
SET LST=Y
Begin DoDot:1
+3 DO ASK
if $GET(QFLG)
QUIT
SET PSOLIST=0
SET PSOPID=1
+4 FOR ORD=1:1:$LENGTH(LST,",")
if $PIECE(LST,",",ORD)']""
QUIT
Begin DoDot:2
+5 KILL ISUF,IFN
SET ORN=$PIECE(LST,",",ORD)
+6 SET RXP=$PIECE(PSOLST($PIECE(LST,",",ORD)),"^",2)
SET POERR=1
+7 if +PSOLST(ORN)=52
DO FULL^VALM1
DO BC1^PSODISP
WRITE !
SET PSOLIST=PSOLIST+1
+8 IF PSOLIST=5
Begin DoDot:3
+9 KILL DIR,DIRUT
SET DIR(0)="E"
SET DIR("A",1)=""
SET DIR("A")="Press Return to Continue"
+10 WRITE !
DO ^DIR
KILL DIR,DIRUT
SET PSOLIST=0
End DoDot:3
End DoDot:2
+11 IF $DATA(DISGROUP)
IF $DATA(BINGNAM)
IF ($DATA(BINGDIV)!$DATA(BNGPDV)!$DATA(BNGRDV))
IF ($DATA(BINGRO)!$DATA(BINGRPR))
NEW TM,TM1
DO REL^PSOBING1
KILL BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
Begin DoDot:2
+12 KILL DIR,DIRUT
SET DIR(0)="E"
SET DIR("A",1)=""
SET DIR("A")="Press Return to Continue"
+13 WRITE !
DO ^DIR
KILL DIR,DIRUT
End DoDot:2
+14 IF $GET(PSORLS)
IF $$STATUS^PSOBPSUT(RXP)]""
IF $$WINFILL^PSODISPS(RXP)
DO SIGMSG^PSODISPS
KILL PSORLS
End DoDot:1
+15 IF '$GET(PSOOELSE)
SET VALMBCK=""
QUIT
+16 SET VALMBCK="R"
SET PSORXED=1
DO BLD^PSOORUT1
EX KILL SPEED,PSOPCECT,PSOOELSE,QFLG,PSORXED,OUT,RX2,RXFD,RESK,ISUF,SUPN,%,DIC,IFN,J,DA,DR,DIE,X,X1,X2,Y,RXP,CX,PX,ORD,LST,POERR,PSOLIST
+1 KILL REC,DIR,YDT,REC,RDUZ,DIRUT,PSOCPN,PSOCPRX,PSOIBSS,PSOIBFL,PSOIBLP,PSOIBST,YY,QDRUG,QTY,TYPE,XTYPE,DUOUT,PSRH,XX,Y,PSIN
+2 QUIT
ASK ;
+1 IF '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
SET VALMSG="Site Parameters must be defined to use the Release option!"
SET VALMBCK="R"
SET QFLG=1
QUIT
+2 SET VALMBCK="Q"
SET Y=$GET(^PS(59,PSOSITE,"IB"))
SET PSOIBSS=$$SERV^IBARX1(+Y)
IF 'PSOIBSS
DO IBSSR^PSOUTL
IF 'PSOIBFL
Begin DoDot:1
+3 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!",!
HANG 3
End DoDot:1
SET VALMBCK="R"
SET QFLG=1
QUIT
+4 WRITE !!
SET PSIN=+$PIECE($GET(^PS(59.7,1,49.99)),"^",2)
RPH 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
SET QFLG=1
QUIT
+1 if Y=-1
GOTO RPH
KILL DIC
IF $DATA(DIRUT)
SET QFLG=1
QUIT
+2 SET PSRH=+Y
+3 ;check for Drug Acct background job K8 & K7.1
+4 SET X="PSA IV ALL LOCATIONS"
SET DIC(0)="MZ"
SET DIC=19.2
DO ^DIC
IF Y=-1
KILL DIC,X,Y
QUIT
+5 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
QUIT
+6 SET X="PSA IV ALL LOCATIONS"
SET DIC(0)="MZ"
SET DIC=19
DO ^DIC
KILL DIC,X
if Y=-1
QUIT
+7 KILL DIQ,PSA
SET DA=+Y
SET DIC=19
SET DIQ="PSA"
SET DR=200
SET DIQ(0)="IN"
DO EN^DIQ1
+8 IF '$DATA(PSA(19,DA,200,"I"))
KILL DIC,DA,X,Y,DIQ
QUIT
+9 IF PSA(19,DA,200,"I")>DT
SET PSODA=1
if '$PIECE($GET(^XTMP("PSA",0)),U,2)
SET $PIECE(^(0),U,2)=DT
+10 KILL PSA,DIC,DA,X,Y,DIQ
+11 QUIT
