PSODISP3.m

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 ---PSODISP3   2938     printed  Feb 18, 2025@23:53:36                                                                                                                                                                                                    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