PSOHLDI1 ;BIR/PWC,SAB - Automated Dispense Completion HL7 v.2.4 cont. ;10/25/06 10:04am
;;7.0;OUTPATIENT PHARMACY;**259,268**;DEC 1997;Build 9
;Reference to ^PSD(58.8 supported by DBIA 1036
;Reference to ^XTMP("PSA" supported by DBIA 1036
;This routine is called by PSOHLDIS
;
;*259 create routine to hold DRGACCT, psohldis exceeded 10k, also
; add MAIL tag for Email Alert to mail group.
;
Q
;
BINGREL ;displays to bingo board
N NAM,NAME,RXO,SSN S ADA="",BRXP=RXID
F XX=0:0 S XX=$O(^PS(52.11,"B",BNAM,XX)) Q:'XX D
.F BRX=0:0 S BRX=$O(^PS(52.11,XX,2,"B",BRX)) Q:'BRX I BRX=BRXP S (DA,ODA)=XX
Q:'$D(DA)
I $P($G(^PS(52.11,DA,0)),"^",7)]"" Q
I $P($P($G(^PS(52.11,DA,0)),"^",5),".")'=DT S DIK="^PS(52.11," D ^DIK K DIK Q
N TM,TM1 D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2)
S NM=$P(^DPT($P(^PS(52.11,DA,0),"^"),0),"^"),DR="6////"_$E(TM1_"0000",1,4)_";8////"_NM_"",DIE="^PS(52.11,"
L +^PS(52.11,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) E Q
D ^DIE L -^PS(52.11,DA) I $G(X)="" S DIK="^PS(52.11," D ^DIK K DIK Q
S RX0=^PS(52.11,DA,0),JOES=$P(RX0,"^",4),TICK=+$P($G(RX0),"^",2),GRP=$P($G(^PS(59.3,$P($G(^PS(52.11,DA,0)),"^",3),0)),"^",2)
I GRP="T",'$G(TICK) S DIK="^PS(52.11," D ^DIK K DIK
Q:'$G(DA)
S PSZ=0 I '$D(^PS(59.2,DT,0)) K DD,DIC,DO,DA S X=DT,DIC="^PS(59.2,",DIC(0)="",DINUM=X D FILE^DICN S PSZ=1 Q:Y'>0
I PSZ=1 S DA(1)=+Y,DIC=DIC_DA(1)_",1,",(DINUM,X)=JOES,DIC(0)="",DIC("P")=$P(^DD(59.2,1,0),"^",2) K DD,DO D FILE^DICN K DIC,DA Q:Y'>0
I PSZ=0 K DD,DIC,DO,DA S DA(1)=DT,(DINUM,X)=JOES,DIC="^PS(59.2,"_DT_",1,",DIC(0)="LZ" D FILE^DICN K DIC,DA,DO
S DA=ODA D STATS1^PSOBRPRT,WTIME^PSOBING1
Q
;
DRGACCT(RXP) ;update Drug Accountability Package ;PSO*209
S RXP=+$G(RXP) Q:'RXP
N PSA,DIC,DA,DR,X,Y,DIQ,PSODA,PSOSITE,QDRUG,QTY,JOB192
S (JOB192,PSODA)=0
;check for Drug Acct background job
S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19.2 D ^DIC S JOB192=Y
I JOB192>0,$P($G(Y(0)),U,2)>DT D
. S PSODA=1
. S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT
I JOB192'>0 D ;check old way of scheduling
. S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19 D ^DIC
. K DIQ,PSA S DA=+Y,DIC=19,DIQ="PSA",DR=200,DIQ(0)="IN" D EN^DIQ1
. I $G(PSA(19,DA,200,"I"))>DT D
. . S PSODA=1
. . S:'$P($G(^XTMP("PSA",0)),U,2) $P(^(0),U,2)=DT
;drug stocked in Drug Acct Location?
S PSOSITE=+$O(^PS(59,0))
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)
;if appropriate update ^XTMP("PSA", for Drug Acct
S QTY=$P($G(^PSRX(RXP,0)),"^",7)
S QDRUG=+$P($G(^PSRX(RXP,0)),"^",6)
Q:'QDRUG
I $G(PSODA),$G(PSODA(1)),'$D(^PSRX("AR",$$NOW^XLFDT,RXP,0)) S ^XTMP("PSA",PSOSITE,QDRUG,DT)=$G(^XTMP("PSA",PSOSITE,QDRUG,DT))+QTY
Q
;
MAIL ;Send mail message
S:'$G(DUZ) DUZ=.5
N PSOTTEXT,PSOIEN,PSOKEYN,XMY,XMDUZ,XMSUB,XMTEXT
S XMY("G.PSO EXTERNAL DISPENSE ALERTS")=""
;if no members in group, then send to PSXCMOPMGR key holders
S PSOIEN=$O(^XMB(3.8,"B","PSO EXTERNAL DISPENSE ALERTS",0))
I '$O(^XMB(3.8,PSOIEN,1,0)) D
. S PSOKEYN=0
. F S PSOKEYN=$O(^XUSEC("PSXCMOPMGR",PSOKEYN)) Q:'PSOKEYN D
. . S XMY(PSOKEYN)=""
S XMDUZ="PSO EXTERNAL DISPENSE"
S XMSUB="External Dispense - Rx Release Attempted"
S PSOTTEXT(1)="Patient: "_NAME_" SSN: "_PSSN
S PSOTTEXT(2)=" Rx #: "_PSORX_" Fill: "_FLLN
S PSOTTEXT(3)=" Drug: "_$P(GIVECOD,"~",2)
S PSOTTEXT(4)=""
S PSOTTEXT(5)=ATXT
S PSOTTEXT(6)=""
S:ACTN]"" PSOTTEXT(7)=ACTN
S XMTEXT="PSOTTEXT(" D ^XMD
Q
PSOHLDI1 ;BIR/PWC,SAB - Automated Dispense Completion HL7 v.2.4 cont. ;10/25/06 10:04am
+1 ;;7.0;OUTPATIENT PHARMACY;**259,268**;DEC 1997;Build 9
+2 ;Reference to ^PSD(58.8 supported by DBIA 1036
+3 ;Reference to ^XTMP("PSA" supported by DBIA 1036
+4 ;This routine is called by PSOHLDIS
+5 ;
+6 ;*259 create routine to hold DRGACCT, psohldis exceeded 10k, also
+7 ; add MAIL tag for Email Alert to mail group.
+8 ;
+9 QUIT
+10 ;
BINGREL ;displays to bingo board
+1 NEW NAM,NAME,RXO,SSN
SET ADA=""
SET BRXP=RXID
+2 FOR XX=0:0
SET XX=$ORDER(^PS(52.11,"B",BNAM,XX))
IF 'XX
QUIT
Begin DoDot:1
+3 FOR BRX=0:0
SET BRX=$ORDER(^PS(52.11,XX,2,"B",BRX))
IF 'BRX
QUIT
IF BRX=BRXP
SET (DA,ODA)=XX
End DoDot:1
+4 IF '$DATA(DA)
QUIT
+5 IF $PIECE($GET(^PS(52.11,DA,0)),"^",7)]""
QUIT
+6 IF $PIECE($PIECE($GET(^PS(52.11,DA,0)),"^",5),".")'=DT
SET DIK="^PS(52.11,"
DO ^DIK
KILL DIK
QUIT
+7 NEW TM,TM1
DO NOW^%DTC
SET TM=$EXTRACT(%,1,12)
SET TM1=$PIECE(TM,".",2)
+8 SET NM=$PIECE(^DPT($PIECE(^PS(52.11,DA,0),"^"),0),"^")
SET DR="6////"_$EXTRACT(TM1_"0000",1,4)_";8////"_NM_""
SET DIE="^PS(52.11,"
+9 LOCK +^PS(52.11,DA):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
IF '$TEST
QUIT
+10 DO ^DIE
LOCK -^PS(52.11,DA)
IF $GET(X)=""
SET DIK="^PS(52.11,"
DO ^DIK
KILL DIK
QUIT
+11 SET RX0=^PS(52.11,DA,0)
SET JOES=$PIECE(RX0,"^",4)
SET TICK=+$PIECE($GET(RX0),"^",2)
SET GRP=$PIECE($GET(^PS(59.3,$PIECE($GET(^PS(52.11,DA,0)),"^",3),0)),"^",2)
+12 IF GRP="T"
IF '$GET(TICK)
SET DIK="^PS(52.11,"
DO ^DIK
KILL DIK
+13 IF '$GET(DA)
QUIT
+14 SET PSZ=0
IF '$DATA(^PS(59.2,DT,0))
KILL DD,DIC,DO,DA
SET X=DT
SET DIC="^PS(59.2,"
SET DIC(0)=""
SET DINUM=X
DO FILE^DICN
SET PSZ=1
IF Y'>0
QUIT
+15 IF PSZ=1
SET DA(1)=+Y
SET DIC=DIC_DA(1)_",1,"
SET (DINUM,X)=JOES
SET DIC(0)=""
SET DIC("P")=$PIECE(^DD(59.2,1,0),"^",2)
KILL DD,DO
DO FILE^DICN
KILL DIC,DA
IF Y'>0
QUIT
+16 IF PSZ=0
KILL DD,DIC,DO,DA
SET DA(1)=DT
SET (DINUM,X)=JOES
SET DIC="^PS(59.2,"_DT_",1,"
SET DIC(0)="LZ"
DO FILE^DICN
KILL DIC,DA,DO
+17 SET DA=ODA
DO STATS1^PSOBRPRT
DO WTIME^PSOBING1
+18 QUIT
+19 ;
DRGACCT(RXP) ;update Drug Accountability Package ;PSO*209
+1 SET RXP=+$GET(RXP)
IF 'RXP
QUIT
+2 NEW PSA,DIC,DA,DR,X,Y,DIQ,PSODA,PSOSITE,QDRUG,QTY,JOB192
+3 SET (JOB192,PSODA)=0
+4 ;check for Drug Acct background job
+5 SET X="PSA IV ALL LOCATIONS"
SET DIC(0)="MZ"
SET DIC=19.2
DO ^DIC
SET JOB192=Y
+6 IF JOB192>0
IF $PIECE($GET(Y(0)),U,2)>DT
Begin DoDot:1
+7 SET PSODA=1
+8 IF '$PIECE($GET(^XTMP("PSA",0)),U,2)
SET $PIECE(^(0),U,2)=DT
End DoDot:1
+9 ;check old way of scheduling
IF JOB192'>0
Begin DoDot:1
+10 SET X="PSA IV ALL LOCATIONS"
SET DIC(0)="MZ"
SET DIC=19
DO ^DIC
+11 KILL DIQ,PSA
SET DA=+Y
SET DIC=19
SET DIQ="PSA"
SET DR=200
SET DIQ(0)="IN"
DO EN^DIQ1
+12 IF $GET(PSA(19,DA,200,"I"))>DT
Begin DoDot:2
+13 SET PSODA=1
+14 IF '$PIECE($GET(^XTMP("PSA",0)),U,2)
SET $PIECE(^(0),U,2)=DT
End DoDot:2
End DoDot:1
+15 ;drug stocked in Drug Acct Location?
+16 SET PSOSITE=+$ORDER(^PS(59,0))
+17 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)
+18 ;if appropriate update ^XTMP("PSA", for Drug Acct
+19 SET QTY=$PIECE($GET(^PSRX(RXP,0)),"^",7)
+20 SET QDRUG=+$PIECE($GET(^PSRX(RXP,0)),"^",6)
+21 IF 'QDRUG
QUIT
+22 IF $GET(PSODA)
IF $GET(PSODA(1))
IF '$DATA(^PSRX("AR",$$NOW^XLFDT,RXP,0))
SET ^XTMP("PSA",PSOSITE,QDRUG,DT)=$GET(^XTMP("PSA",PSOSITE,QDRUG,DT))+QTY
+23 QUIT
+24 ;
MAIL ;Send mail message
+1 IF '$GET(DUZ)
SET DUZ=.5
+2 NEW PSOTTEXT,PSOIEN,PSOKEYN,XMY,XMDUZ,XMSUB,XMTEXT
+3 SET XMY("G.PSO EXTERNAL DISPENSE ALERTS")=""
+4 ;if no members in group, then send to PSXCMOPMGR key holders
+5 SET PSOIEN=$ORDER(^XMB(3.8,"B","PSO EXTERNAL DISPENSE ALERTS",0))
+6 IF '$ORDER(^XMB(3.8,PSOIEN,1,0))
Begin DoDot:1
+7 SET PSOKEYN=0
+8 FOR
SET PSOKEYN=$ORDER(^XUSEC("PSXCMOPMGR",PSOKEYN))
IF 'PSOKEYN
QUIT
Begin DoDot:2
+9 SET XMY(PSOKEYN)=""
End DoDot:2
End DoDot:1
+10 SET XMDUZ="PSO EXTERNAL DISPENSE"
+11 SET XMSUB="External Dispense - Rx Release Attempted"
+12 SET PSOTTEXT(1)="Patient: "_NAME_" SSN: "_PSSN
+13 SET PSOTTEXT(2)=" Rx #: "_PSORX_" Fill: "_FLLN
+14 SET PSOTTEXT(3)=" Drug: "_$PIECE(GIVECOD,"~",2)
+15 SET PSOTTEXT(4)=""
+16 SET PSOTTEXT(5)=ATXT
+17 SET PSOTTEXT(6)=""
+18 IF ACTN]""
SET PSOTTEXT(7)=ACTN
+19 SET XMTEXT="PSOTTEXT("
DO ^XMD
+20 QUIT
