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
Q
;
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_"***"
Q
;
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
Q
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
Q
ENPG K DIR,DUOUT,DTOUT,DIRUT S DIR(0)="E"
D ^DIR S:'Y EXT=1
K DIR,DTOUT,DIRUT,DUOUT W @IOF
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOBGMG3 3977 printed Sep 23, 2025@20:01:01 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
