Routine: PSOBGMG3

PSOBGMG3 ;BHAM ISC/LC - BINGO BOARD MANAGER (CONT'D) ;03/02/15  18:05

 ;;7.0;OUTPATIENT PHARMACY;**11,77,441**;DEC 1997;Build 208

 ;External reference to PS(50.7 is supported by DBIA 2223

 ;External reference to PSDRUG( is supported by DBIA 221

STATUS ;

STATUS1 N DA,DIC,DIK,NDA,NDA1,PAS,PAS1,RX,RX1,RXNUM,XX,Y

 S (EXT,DTME,RX,OLDT)="",(CNT,CNT1,RXNUM)=0

 W ! K DIC,DLAYGO S DIC=2,DIC(0)="AEMQZ",DIC("S")="I $D(^PS(52.11,""B"",+Y))!($D(^PS(52.41,""AOR"",+Y)))",DIC("A")="Enter Patient Name: " D ^DIC K DIC G:+Y'>0!($G(DTOUT))!($G(DUOUT)) EX S NAM=Y(0,0),NNUM=+Y

BING ;do not remove this entry point SAB

 S NNAM="" F  S NNAM=$O(^PS(52.11,"BA",NNAM)) Q:NNAM=""  I NAM=NNAM D

 .F NDA=0:0 S NDA=$O(^PS(52.11,"BA",NNAM,NDA)) Q:'NDA  I +$G(^PS(52.11,NDA,0))=$G(NNUM) S CNT=CNT+1,NDA(CNT)=NDA

PEND F NNAM=0:0  S NNAM=$O(^PS(52.41,"AOR",NNAM)) Q:'NNAM  I NNAM=$G(NNUM),NAM=$P($G(^DPT(NNAM,0)),"^") D

 .F NDAINS=0:0 S NDAINS=$O(^PS(52.41,"AOR",NNAM,NDAINS)) Q:'NDAINS  F NDA=0:0 S NDA=$O(^PS(52.41,"AOR",NNAM,NDAINS,NDA)) Q:'NDA  S CNT1=CNT1+1,NDA1(CNT1)=NDA

 F LP=0:0 S LP=$O(NDA(LP)) Q:('LP)!$G(EXT)  S DA=NDA(LP) D OLDT,PRSE

 F LP=0:0 S LP=$O(NDA1(LP)) Q:('LP)!$G(EXT)  S DA=NDA1(LP) D:$G(^PS(52.41,DA,0)) PRSE1

 K CNT,CNT1,LP,NDA,NDA1,NAM,NNAM,OI,OLDT,PAS,PAS1,NDAINS

 G:'$G(PSOHA) STATUS1

EX K CNT,CNT1,DG,EXT,LP,NDA,NDA1,NAM,NNAM,NNUM,OI,OLDT,PAS,PAS1,DA,DIC,DIK,DTME,DIS,DIV,PKP,TIN,TOUT,XX,Y,PN,ODTP,EBY,PROV,DRG,LOGDT,MW

OLDT ;

 S OLDT="" I $P($P($G(^PS(52.11,DA,0)),"^",5),".")'=DT S Y=$P($P($G(^PS(52.11,DA,0)),"^",5),".") D DD^%DT S OLDT="***Entered on "_Y_"***"

PRSE ;

 S RX="",RX1="",RXNUM=0

 F XX=0:0 S XX=$O(^PS(52.11,DA,2,"B",XX)) Q:'XX  S XX1=$S($G(^PSRX(XX,0)):$P(^(0),"^"),1:XX) D

 .S:$L(RX_XX1)>200 RX1=RX1_XX1_", " S:$L(RX_XX1)<200 RX=RX_XX1_", ",RXNUM=RXNUM+1

 S DTME=$P(^PS(52.11,DA,0),"^",5),DIS=$S($P(^(0),"^",7)'="":1,1:0),DIV=$P(^(0),"^",4),DG=$P(^(0),"^",3),TIN=$P(^(0),"^",6),TOUT=$P(^(0),"^",7)

 S PKP=$S($D(^PS(52.11,"AD",DG,DA)):1,1:0),PKPD=$S($D(^PS(52.11,"ANAMK",DA,DG,NNUM)):1,1:0)

 S TIN=+$E(TIN,1,2)_":"_$E(TIN,3,4),TOUT=+$E(TOUT,1,2)_":"_$E(TOUT,3,4) S Y=DTME X ^DD("DD") S DTME=Y

 W:'$G(PAS) @IOF,!,?8,NAM_" has the following orders for "_+$E(DT,4,5)_"/"_+$E(DT,6,7)_"/"_$E(DT,2,3)

 I '$G(DIS) W !!,"Being Processed: "_OLDT,!,?3,"Division: "_$P(^PS(59,DIV,0),"^"),?42,"Time In: "_TIN,?60,"Time Out: ",!,?3,"Rx #: "_RX W:$G(RX1) !,?3,RX1

 I $Y+6>IOSL D ENPG Q:$G(EXT)

 I $G(DIS),$G(PKP),'$G(PKPD) W !!,"Ready For Pickup: ",!,?3,"Division: "_$P(^PS(59,DIV,0),"^"),?42,"Time In: "_TIN,?60,"Time Out: "_TOUT,!,?3,"Rx #: "_RX W:$G(RX1) !,?3,RX1

 I $Y+6>IOSL D ENPG Q:$G(EXT)

 ;*****Picked Up status is dependent on wait time stored in ^PSRX*****

 I $G(DIS),$G(PKPD) W !!,"Picked Up: ",!,?3,"Division: "_$P(^PS(59,DIV,0),"^"),?42,"Time In: "_TIN,?60,"Time Out: "_TOUT,!,?3,"Rx #: "_RX W:$G(RX1) !,?3,RX1

 I $Y+6>IOSL D ENPG Q:$G(EXT)

 S PAS=1

STEX K DA,DIC,DG,DIK,DTME,DIS,DIV,PKP,PKPD,TIN,TOUT,XX,XX1,Y

PRSE1 ;PENDING

 Q:$P(^PS(52.41,DA,0),"^",3)="RF"

 S PN=$P(^PS(52.41,DA,0),"^"),ODTP=$P(^(0),"^",3),EBY=$P(^(0),"^",4),PROV=$P(^(0),"^",5),DRG=$P(^(0),"^",9),LOGDT=$P(^(0),"^",12),MW=$P(^(0),"^",17),OI=$P(^(0),"^",8)

 S Y=LOGDT,LOGDT=+$E(Y,4,5)_"/"_+$E(Y,6,7)_"/"_$E(Y,2,3)_"@"_$E($P(Y,".",2),1,2)_":"_$E($P(Y,".",2),3,4)

 ;format text for screen

 W:'$G(PAS)&('$G(PAS1)) @IOF,!,?8,NAM_" has the following orders for "_+$E(DT,4,5)_"/"_+$E(DT,6,7)_"/"_$E(DT,2,3)

 W !!,"Pending: ",!,?3,"Orderable Item: "_$P(^PS(50.7,OI,0),"^"),?52,"Provider: "_$P(^VA(200,PROV,0),"^")

 W !,?3,"Entered By: "_$P(^VA(200,EBY,0),"^"),?52,"Time In: "_LOGDT

 W !,?3,"Drug: "_$S($G(DRG):$P(^PSDRUG(DRG,0),"^"),1:""),?52,"Routing: "_$S($G(MW)="M":"MAIL",$G(MW)="P":"PARK",1:"WINDOW")  ;441 PAPI

 I $Y+6>IOSL D ENPG Q:$G(EXT)

STEX1 K DA,DIC,DIK,PN,ODTP,EBY,PROV,DRG,LOGDT,MW,XX,XX1,Y

 S PAS1=1

ENPG K DIR,DUOUT,DTOUT,DIRUT S DIR(0)="E"

 D ^DIR S:'Y EXT=1

 K DIR,DTOUT,DIRUT,DUOUT W @IOF

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOBGMG3   3977     printed  Feb 18, 2025@23:51:12                                                                                                                                                                                                    Page 2

PSOBGMG3  ;BHAM ISC/LC - BINGO BOARD MANAGER (CONT'D) ;03/02/15  18:05

 +1       ;;7.0;OUTPATIENT PHARMACY;**11,77,441**;DEC 1997;Build 208

 +2       ;External reference to PS(50.7 is supported by DBIA 2223

 +3       ;External reference to PSDRUG( is supported by DBIA 221

 +4       ;

STATUS    ;

STATUS1    NEW DA,DIC,DIK,NDA,NDA1,PAS,PAS1,RX,RX1,RXNUM,XX,Y

 +1        SET (EXT,DTME,RX,OLDT)=""

           SET (CNT,CNT1,RXNUM)=0

 +2        WRITE !

           KILL DIC,DLAYGO

           SET DIC=2

           SET DIC(0)="AEMQZ"

           SET DIC("S")="I $D(^PS(52.11,""B"",+Y))!($D(^PS(52.41,""AOR"",+Y)))"

           SET DIC("A")="Enter Patient Name: "

           DO ^DIC

           KILL DIC

           if +Y'>0!($GET(DTOUT))!($GET(DUOUT))

               GOTO EX

           SET NAM=Y(0,0)

           SET NNUM=+Y

BING      ;do not remove this entry point SAB

 +1        SET NNAM=""

FOR

               SET NNAM=$ORDER(^PS(52.11,"BA",NNAM))

               if NNAM=""

                   QUIT

               IF NAM=NNAM

                   Begin DoDot:1

 +2                    FOR NDA=0:0

                           SET NDA=$ORDER(^PS(52.11,"BA",NNAM,NDA))

                           if 'NDA

                               QUIT

                           IF +$GET(^PS(52.11,NDA,0))=$GET(NNUM)

                               SET CNT=CNT+1

                               SET NDA(CNT)=NDA

                   End DoDot:1

PEND       FOR NNAM=0:0

               SET NNAM=$ORDER(^PS(52.41,"AOR",NNAM))

               if 'NNAM

                   QUIT

               IF NNAM=$GET(NNUM)

                   IF NAM=$PIECE($GET(^DPT(NNAM,0)),"^")

                       Begin DoDot:1

 +1                        FOR NDAINS=0:0

                               SET NDAINS=$ORDER(^PS(52.41,"AOR",NNAM,NDAINS))

                               if 'NDAINS

                                   QUIT

                               FOR NDA=0:0

                                   SET NDA=$ORDER(^PS(52.41,"AOR",NNAM,NDAINS,NDA))

                                   if 'NDA

                                       QUIT

                                   SET CNT1=CNT1+1

                                   SET NDA1(CNT1)=NDA

                       End DoDot:1

 +2        FOR LP=0:0

               SET LP=$ORDER(NDA(LP))

               if ('LP)!$GET(EXT)

                   QUIT

               SET DA=NDA(LP)

               DO OLDT

               DO PRSE

 +3        FOR LP=0:0

               SET LP=$ORDER(NDA1(LP))

               if ('LP)!$GET(EXT)

                   QUIT

               SET DA=NDA1(LP)

               if $GET(^PS(52.41,DA,0))

                   DO PRSE1

 +4        KILL CNT,CNT1,LP,NDA,NDA1,NAM,NNAM,OI,OLDT,PAS,PAS1,NDAINS

 +5        if '$GET(PSOHA)

               GOTO STATUS1

EX         KILL CNT,CNT1,DG,EXT,LP,NDA,NDA1,NAM,NNAM,NNUM,OI,OLDT,PAS,PAS1,DA,DIC,DIK,DTME,DIS,DIV,PKP,TIN,TOUT,XX,Y,PN,ODTP,EBY,PROV,DRG,LOGDT,MW

 +1        QUIT

 +2       ;

OLDT      ;

 +1        SET OLDT=""

           IF $PIECE($PIECE($GET(^PS(52.11,DA,0)),"^",5),".")'=DT

               SET Y=$PIECE($PIECE($GET(^PS(52.11,DA,0)),"^",5),".")

               DO DD^%DT

               SET OLDT="***Entered on "_Y_"***"

 +2        QUIT

 +3       ;

PRSE      ;

 +1        SET RX=""

           SET RX1=""

           SET RXNUM=0

 +2        FOR XX=0:0

               SET XX=$ORDER(^PS(52.11,DA,2,"B",XX))

               if 'XX

                   QUIT

               SET XX1=$SELECT($GET(^PSRX(XX,0)):$PIECE(^(0),"^"),1:XX)

               Begin DoDot:1

 +3                if $LENGTH(RX_XX1)>200

                       SET RX1=RX1_XX1_", "

                   if $LENGTH(RX_XX1)<200

                       SET RX=RX_XX1_", "

                       SET RXNUM=RXNUM+1

               End DoDot:1

 +4        SET DTME=$PIECE(^PS(52.11,DA,0),"^",5)

           SET DIS=$SELECT($PIECE(^(0),"^",7)'="":1,1:0)

           SET DIV=$PIECE(^(0),"^",4)

           SET DG=$PIECE(^(0),"^",3)

           SET TIN=$PIECE(^(0),"^",6)

           SET TOUT=$PIECE(^(0),"^",7)

 +5        SET PKP=$SELECT($DATA(^PS(52.11,"AD",DG,DA)):1,1:0)

           SET PKPD=$SELECT($DATA(^PS(52.11,"ANAMK",DA,DG,NNUM)):1,1:0)

 +6        SET TIN=+$EXTRACT(TIN,1,2)_":"_$EXTRACT(TIN,3,4)

           SET TOUT=+$EXTRACT(TOUT,1,2)_":"_$EXTRACT(TOUT,3,4)

           SET Y=DTME

           XECUTE ^DD("DD")

           SET DTME=Y

 +7        if '$GET(PAS)

               WRITE @IOF,!,?8,NAM_" has the following orders for "_+$EXTRACT(DT,4,5)_"/"_+$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)

 +8        IF '$GET(DIS)

               WRITE !!,"Being Processed: "_OLDT,!,?3,"Division: "_$PIECE(^PS(59,DIV,0),"^"),?42,"Time In: "_TIN,?60,"Time Out: ",!,?3,"Rx #: "_RX

               if $GET(RX1)

                   WRITE !,?3,RX1

 +9        IF $Y+6>IOSL

               DO ENPG

               if $GET(EXT)

                   QUIT

 +10       IF $GET(DIS)

               IF $GET(PKP)

                   IF '$GET(PKPD)

                       WRITE !!,"Ready For Pickup: ",!,?3,"Division: "_$PIECE(^PS(59,DIV,0),"^"),?42,"Time In: "_TIN,?60,"Time Out: "_TOUT,!,?3,"Rx #: "_RX

                       if $GET(RX1)

                           WRITE !,?3,RX1

 +11       IF $Y+6>IOSL

               DO ENPG

               if $GET(EXT)

                   QUIT

 +12      ;*****Picked Up status is dependent on wait time stored in ^PSRX*****

 +13       IF $GET(DIS)

               IF $GET(PKPD)

                   WRITE !!,"Picked Up: ",!,?3,"Division: "_$PIECE(^PS(59,DIV,0),"^"),?42,"Time In: "_TIN,?60,"Time Out: "_TOUT,!,?3,"Rx #: "_RX

                   if $GET(RX1)

                       WRITE !,?3,RX1

 +14       IF $Y+6>IOSL

               DO ENPG

               if $GET(EXT)

                   QUIT

 +15       SET PAS=1

STEX       KILL DA,DIC,DG,DIK,DTME,DIS,DIV,PKP,PKPD,TIN,TOUT,XX,XX1,Y

 +1        QUIT

PRSE1     ;PENDING

 +1        if $PIECE(^PS(52.41,DA,0),"^",3)="RF"

               QUIT

 +2        SET PN=$PIECE(^PS(52.41,DA,0),"^")

           SET ODTP=$PIECE(^(0),"^",3)

           SET EBY=$PIECE(^(0),"^",4)

           SET PROV=$PIECE(^(0),"^",5)

           SET DRG=$PIECE(^(0),"^",9)

           SET LOGDT=$PIECE(^(0),"^",12)

           SET MW=$PIECE(^(0),"^",17)

           SET OI=$PIECE(^(0),"^",8)

 +3        SET Y=LOGDT

           SET LOGDT=+$EXTRACT(Y,4,5)_"/"_+$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)_"@"_$EXTRACT($PIECE(Y,".",2),1,2)_":"_$EXTRACT($PIECE(Y,".",2),3,4)

 +4       ;format text for screen

 +5        if '$GET(PAS)&('$GET(PAS1))

               WRITE @IOF,!,?8,NAM_" has the following orders for "_+$EXTRACT(DT,4,5)_"/"_+$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3)

 +6       ;

 +7        WRITE !!,"Pending: ",!,?3,"Orderable Item: "_$PIECE(^PS(50.7,OI,0),"^"),?52,"Provider: "_$PIECE(^VA(200,PROV,0),"^")

 +8        WRITE !,?3,"Entered By: "_$PIECE(^VA(200,EBY,0),"^"),?52,"Time In: "_LOGDT

 +9       ;441 PAPI

           WRITE !,?3,"Drug: "_$SELECT($GET(DRG):$PIECE(^PSDRUG(DRG,0),"^"),1:""),?52,"Routing: "_$SELECT($GET(MW)="M":"MAIL",$GET(MW)="P":"PARK",1:"WINDOW")

 +10       IF $Y+6>IOSL

               DO ENPG

               if $GET(EXT)

                   QUIT

STEX1      KILL DA,DIC,DIK,PN,ODTP,EBY,PROV,DRG,LOGDT,MW,XX,XX1,Y

 +1        SET PAS1=1

 +2        QUIT

ENPG       KILL DIR,DUOUT,DTOUT,DIRUT

           SET DIR(0)="E"

 +1        DO ^DIR

           if 'Y

               SET EXT=1

 +2        KILL DIR,DTOUT,DIRUT,DUOUT

           WRITE @IOF

 +3        QUIT

PSOBGMG3.m