PSOHLDI1 ;BIR/PWC,SAB - Automated Dispense Completion HL7 v.2.4 cont. ;5/29/09 3:28pm
;;7.0;OUTPATIENT PHARMACY;**259,268,330,446**;DEC 1997;Build 20
;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,PSOSITE) ;update Drug Accountability Package PSO*209,*330
S RXP=+$G(RXP) Q:'RXP
S PSOSITE=+$G(PSOSITE) Q:'PSOSITE ; PSO*7*330
N PSA,DIC,DA,DR,X,Y,DIQ,PSODA,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 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 USR,PSOTTEXT,XMY,XMDUZ,XMSUB,XMTEXT
;if no Active members in group, then send to PSXCMOPMGR key holders
I $$GOTLOCAL^XMXAPIG("PSO EXTERNAL DISPENSE ALERTS") D
. S XMY("G.PSO EXTERNAL DISPENSE ALERTS")=""
E D
. S USR=0 F S USR=$O(^XUSEC("PSXCMOPMGR",USR)) Q:'USR S XMY(USR)=""
I $G(FLL)'="" D
. I FLL="P" S FLLN="Partial "_FLLN
S XMDUZ="PSO EXTERNAL DISPENSE"
S XMSUB=$S($G(PSOSITE):$$GET1^DIQ(59,PSOSITE,.06)_" ",1:"")_"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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLDI1 3593 printed Oct 16, 2024@18:30:22 Page 2
PSOHLDI1 ;BIR/PWC,SAB - Automated Dispense Completion HL7 v.2.4 cont. ;5/29/09 3:28pm
+1 ;;7.0;OUTPATIENT PHARMACY;**259,268,330,446**;DEC 1997;Build 20
+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,PSOSITE) ;update Drug Accountability Package PSO*209,*330
+1 SET RXP=+$GET(RXP)
if 'RXP
QUIT
+2 ; PSO*7*330
SET PSOSITE=+$GET(PSOSITE)
if 'PSOSITE
QUIT
+3 NEW PSA,DIC,DA,DR,X,Y,DIQ,PSODA,QDRUG,QTY,JOB192
+4 SET (JOB192,PSODA)=0
+5 ;check for Drug Acct background job
+6 SET X="PSA IV ALL LOCATIONS"
SET DIC(0)="MZ"
SET DIC=19.2
DO ^DIC
SET JOB192=Y
+7 IF JOB192>0
IF $PIECE($GET(Y(0)),U,2)>DT
Begin DoDot:1
+8 SET PSODA=1
+9 if '$PIECE($GET(^XTMP("PSA",0)),U,2)
SET $PIECE(^(0),U,2)=DT
End DoDot:1
+10 ;check old way of scheduling
IF JOB192'>0
Begin DoDot:1
+11 SET X="PSA IV ALL LOCATIONS"
SET DIC(0)="MZ"
SET DIC=19
DO ^DIC
+12 KILL DIQ,PSA
SET DA=+Y
SET DIC=19
SET DIQ="PSA"
SET DR=200
SET DIQ(0)="IN"
DO EN^DIQ1
+13 IF $GET(PSA(19,DA,200,"I"))>DT
Begin DoDot:2
+14 SET PSODA=1
+15 if '$PIECE($GET(^XTMP("PSA",0)),U,2)
SET $PIECE(^(0),U,2)=DT
End DoDot:2
End DoDot:1
+16 ;drug stocked in Drug Acct Location?
+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 USR,PSOTTEXT,XMY,XMDUZ,XMSUB,XMTEXT
+3 ;if no Active members in group, then send to PSXCMOPMGR key holders
+4 IF $$GOTLOCAL^XMXAPIG("PSO EXTERNAL DISPENSE ALERTS")
Begin DoDot:1
+5 SET XMY("G.PSO EXTERNAL DISPENSE ALERTS")=""
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 SET USR=0
FOR
SET USR=$ORDER(^XUSEC("PSXCMOPMGR",USR))
if 'USR
QUIT
SET XMY(USR)=""
End DoDot:1
+8 IF $GET(FLL)'=""
Begin DoDot:1
+9 IF FLL="P"
SET FLLN="Partial "_FLLN
End DoDot:1
+10 SET XMDUZ="PSO EXTERNAL DISPENSE"
+11 SET XMSUB=$SELECT($GET(PSOSITE):$$GET1^DIQ(59,PSOSITE,.06)_" ",1:"")_"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
