- 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
