Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BOPCAP

BOPCAP.m

Go to the documentation of this file. 
  1. BOPCAP ;IHS/ILC/ALG/CIA/PLS - ILC ADT Event & Segments ;20-Nov-2006 09:22;SM
  1.  ;;1.0;AUTOMATED DISPENSING INTERFACE;**1,2**;Jul 26, 2005
  1.  ;Called from BOP DG ADT protocol
  1.  ;Modified - IHS/MSC/PLS - 11/20/06 - Line MSH1+8 - Corrected issue with Allergies
  1. ADT ; PEP - Capture ADT Events
  1.  ; Check for ADT active
  1.  Q:'$P($G(^BOP(90355,1,2)),U)
  1.  ; Check for send inpatient ADT active
  1.  Q:'$P($G(^BOP(90355,1,2)),U,7)
  1.  ;
  1.  G:'$G(DFN) END S BOPDFN=DFN
  1.  D INIT G:$G(BOPQ) END
  1.  W !,"...updating "_$S(BOPWHO="O":"Omnicell",1:"Pyxis")_" data base..."
  1.  D PID^BOPCP,PV1^BOPCP,AL1^BOPCP
  1.  D OBXH^BOPCP,OBXW^BOPCP,DG1^BOPCP
  1.  N VAIP,VAROOT S VAIP("D")="LAST",VAROOT="BOPVA"
  1.  D IN5^VADPT K VAROOT,VAIP("D")
  1.  N X S X=$P($G(BOPVA(2)),U) G:45[X!(X>6) END  ;Exclude lodger or specialty transfer
  1.  I +$G(BOPVA(1))'=+$G(DGPMVI(1))&(+$G(BOPVA(1))>+$G(DGPMVI(1))) G:X=6 END D
  1.  .S BOP(.02)=$S(X=1:"A01",X=2:"A02",1:"A03")
  1.  .I BOP(.02)="A02"&($P($G(BOP10),U,1)="O") S BOP(.02)="A07"
  1.  .S BOP(.03)=$P($G(BOPVA(3)),U)
  1.  E  S BOP(.02)="A02" S BOP(.03)=$$DT()
  1.  S BOP(.04)="ADT" ;Message Type
  1.  S BOPDIV=$$DIV()
  1.  G:'BOPDIV END
  1.  ;
  1.  I $P(BOP10,U,1)="O"&($P(BOP10,U,2)="")&($P($G(^BOP(90355,1,"SITE")),U,5)) D  ;->
  1.  .  N A,B,C S A=$P($G(^BOP(90355,1,"SITE")),U,6)
  1.  .  I 'A S $P(BOP10,U,2)="AEC" Q  ;->
  1.  .  I A S B=$P($G(^SC(+A,0)),U,1),$P(C,U,2)=B,$P(C,U,3)=$P($G(^BOP(90355,1,"SITE")),U,4)
  1.  .  I $L($P(C,U,2)) S $P(BOP10,U,2)=$P(C,U,2)
  1.  .  I $P(C,U,3)'="" S $P(BOP10,U,2)=$P(C,U,3)
  1.  .  Q  ;->
  1.  ;
  1.  K BOPQ D MSH G:$G(BOPQ) END D FLAG
  1.  W !,"done."
  1.  G END
  1. STAT ;Called from Xref on STATUS field of UNIT DOSE field of File 55
  1.  Q:'$P($G(^BOP(90355,1,2)),U,4)
  1.  S BOPDC=$G(DC)
  1.  G:'$G(DA(1)) END G:'$G(DA) END
  1.  S BOPDFN=DA(1),BOPORDN=DA
  1.  ;
  1. STAT1 ;
  1.  I $G(BOPDC)="" S BOPDC=$P($G(^PS(55,BOPDFN,5,BOPORDN,0)),U,9)
  1.  S BOPDIV=$$DIV() G:'BOPDIV END
  1.  N DFN S DFN=BOPDFN
  1.  F BOPI=0:0 S BOPI=$O(^PS(55,BOPDFN,5,BOPORDN,1,BOPI)) Q:BOPI<1  D
  1.  .D INIT Q:$G(BOPQ)
  1.  .S BOP(2.1)=$G(BOPDC)
  1.  .I BOP(2.1)]"" S BOP(2.1)=$S(BOPDC="R":"DC",BOPDC["D":"DC",BOPDC="H":"HD",BOPDC="A":"RL",BOPDC="RE":"NW",BOPDC="E":"DC",BOPDC="X":($S(BOPWHO="O":"XX",1:"XO")),1:"")
  1.  .Q:BOP(2.1)=""
  1.  .S BOP(8.2)="" ;Initial Dose
  1.  .D ORDER Q:$G(BOPQ)
  1.  .N X S X=$P(BOPX0,U,3)
  1.  .S BOP(8.1)=$G(^PS(51.2,+X,0)) ;Med Route
  1.  .S BOP(8.1)=$S($L($P(BOP(8.1),U))'>10:$P(BOP(8.1),U),1:$P(BOP(8.1),U,3))   ;DUG 1/30/03
  1.  .S BOP(8.3)=$P($G(^PS(55,BOPDFN,5,BOPORDN,0)),U,16)
  1.  .S BOP8=BOP(8.1)_U_BOP(8.2)_U_BOP(8.3)
  1.  .S ^BOP(90355.1,BOPDA,8)=BOP8
  1.  .D FLAG
  1.  G END
  1.  ;
  1.  ;Called from ^PSGOETO
  1. NEW ;PEP - New Order
  1.  Q:'$P($G(^BOP(90355,1,2)),U,2)
  1.  G:'$G(PSGP) END S BOPDFN=PSGP
  1.  G:'$G(PSGORD) END S BOPORDN=+PSGORD
  1.  G:'$P($G(^PS(55,BOPDFN,5,BOPORDN,4)),U,3) END
  1.  S BOPDIV=$$DIV() G:'BOPDIV END
  1.  F BOPI=0:0 S BOPI=$O(^PS(55,BOPDFN,5,BOPORDN,1,BOPI)) Q:BOPI<1  D
  1.  .D INIT Q:$G(BOPQ)
  1.  .S BOP(2.1)="NW" ;New Order
  1.  .S BOP(8.2)="" ;Batch Fill
  1.  .D ORDER Q:$G(BOPQ)
  1.  .N X S X=$P(BOPX0,U,3)
  1.  .S BOP(8.1)=$G(^PS(51.2,+X,0)) ;Med Route
  1.  .S BOP(8.1)=$S($L($P(BOP(8.1),U))'>10:$P(BOP(8.1),U),1:$P(BOP(8.1),U,3))   ;DUG 1/30/03
  1.  .S BOP(8.3)="" ;Fill Cycle Start Date/Time
  1.  .S BOP8=BOP(8.1)_U_BOP(8.2)_U_BOP(8.3)
  1.  .S ^BOP(90355.1,BOPDA,8)=BOP8
  1.  .D FLAG
  1.  G END
  1.  ;
  1. ORDDT ;entry for change in stop dt
  1.  N PSGP,PSGOORD S PSGP=+DA(1),PSGOORD=+DA
  1.  ;
  1. RENEW ;PEP - Renewal
  1.  ; use PSGP instead of DA(1) and PSGOORD instead of DA for DA issue
  1.  Q:'$G(PSGP)  Q:'$G(PSGOORD)
  1.  ;  Q:'$G(DA)  Q:'$G(DA(1))
  1.  ;  Q:'$D(^PS(55,DA(1),5,DA,0))
  1.  Q:'$D(^PS(55,PSGP,5,+PSGOORD,0))
  1.  Q:'$P($G(^BOP(90355,1,2)),U,3)
  1.  S BOPDC=$P(^PS(55,PSGP,5,+PSGOORD,0),U,9)
  1.  S BOPDFN=PSGP,BOPORDN=+PSGOORD
  1.  G:BOPDC="E" END
  1.  ; S BOPDC="X"
  1.  ; S BOPDC="D"
  1.  ; Change above to set eq "d" if not "r" or "re"
  1.  I $E(BOPDC,1)'="R"&($E(BOPDC,1)'="A") S BOPDC="D"
  1.  ;
  1.  G STAT1
  1.  Q
  1. ORDER ; EP - SET UP ORDER INFO
  1.  D ORC
  1.  D RXE^BOPCP,PID^BOPCP,PV1^BOPCP
  1.  ;D OBXH^BOPCP,OBXW^BOPCP  ;UNCOMMENT TO INCLUDE HEIGHT AND WEIGHT
  1.  S BOP(.02)="O01" ;Event Type
  1.  S BOP(.03)=""
  1.  S BOP(.04)="RDE" ;Message Type
  1.  K BOPQ D MSH Q:$G(BOPQ)
  1.  S:$D(BOP2) ^BOP(90355.1,BOPDA,2)=BOP2
  1.  S:$D(BOP3) ^BOP(90355.1,BOPDA,3)=BOP3
  1.  S:$D(BOP4) ^BOP(90355.1,BOPDA,4)=BOP4
  1.  S:$D(BOP5) ^BOP(90355.1,BOPDA,5)=BOP5
  1.  S:$D(BOP6) ^BOP(90355.1,BOPDA,6)=BOP6 Q
  1.  ;
  1. MSH ;EP - Get MSH and EVN Segment Data
  1.  ;.02=Event Type Code, .03=Date/Time of Event, .04=Message Type
  1.  S BOP0=U_BOP(.02)_U_BOP(.03)_U_BOP(.04)
  1.  S BOP0=BOP0_U_U_BOPRAP_U_U_BOPPID_U_BOPVER
  1.  ;
  1.  ;If being processed from "DATA" do not create new entry
  1.  S BOPY=$$DT()
  1.  I $G(BOPNONU) D  G MSH1
  1.  .S Y=BOPDA_U_$P(^BOP(90355.1,BOPDA,0),U)
  1.  ;Create new entry if necessary
  1.  N I
  1.  F I=1:1:3 D  Q:$P(Y,U,3)  H 1
  1.  .N DIC K DO,DD S DIC="^BOP(90355.1,",DIC(0)="L",X=BOPY D FILE^DICN
  1.  I '$P(Y,U,3) S BOPQ=1 Q
  1.  S BOPDA=+Y
  1.  ;
  1. MSH1 S $P(BOP0,U,5)=BOPY,$P(BOP0,U,7)=$P(Y,U,2)
  1.  S $P(^BOP(90355.1,BOPDA,0),U,2,9)=$P(BOP0,U,2,9)
  1.  S $P(^BOP(90355.1,BOPDA,0),U,12)=$G(BOPDIV)
  1.  S $P(^BOP(90355.1,BOPDA,0),U,21)=$G(BOP(.21))
  1.  S:BOP1]"" ^BOP(90355.1,BOPDA,1)=BOP1
  1.  S:BOP(.02)="A03" $P(BOP10,U,7)=$P($G(BOPVA(3)),U)
  1.  S:BOP10]"" ^BOP(90355.1,BOPDA,10)=BOP10
  1.  I $D(BOP9) I BOP9'="^"&(BOP9'="") S ^BOP(90355.1,BOPDA,9)=BOP9
  1.  I $D(BOP11(0)) D
  1.  .K ^BOP(90355.1,BOPDA,11)
  1.  .M ^BOP(90355.1,BOPDA,11)=BOP11
  1.  I $D(BOP12) S ^BOP(90355.1,BOPDA,12)=BOP12
  1.  I $D(BOP14) S ^BOP(90355.1,BOPDA,14)=BOP14
  1.  Q
  1. ORC ;Get ORC Segment Data
  1.  G ORC^BOPCP ; put in BOPOCP for program space
  1.  ;
  1. INIT ;EP - Init variables
  1.  N X K BOPQ I '$D(^BOP(90355,1,0)) S BOPQ=1 Q
  1.  S U="^",X=^BOP(90355,1,0),BOPIT=$P(X,U,2),BOPRAP=$P(X,U,3)
  1.  S BOPPID=$P(X,U,12),BOPVER=$P(X,U,13),BOPBAT=$P(X,U,14)
  1.  S BOPWHO=$G(^BOP(90355,1,2)),BOPWHO=$P(BOPWHO,U,5)
  1.  S:BOPWHO="" BOPWHO="P"
  1.  Q
  1.  ;
  1. VER(PREFIX) ; EP - Return current version of Prefix
  1.  Q +$$VERSION^XPDUTL(PREFIX)
  1.  ;
  1. FLAG ;EP - SET READY FLAG
  1.  S $P(^BOP(90355.1,BOPDA,0),U,10)=0
  1.  S ^BOP(90355.1,"AS",0,BOPDA)=""
  1.  I $G(BOP(.04))="ADT" S ^BOP(90355.1,"AD",BOP(.03),BOPDA)=""
  1.  N DA,DIK S DA=BOPDA,DIK="^BOP(90355.1," D IX1^DIK K DA,DIK
  1.  Q
  1.  ;
  1. DT() ; EP - SET DATE
  1.  Q $$NOW^XLFDT()
  1.  ;
  1. END ; EP - KILL VARIABLES
  1.  K BOP,BOP0,BOP1,BOP10,BOP2,BOP3,BOP4,BOP5,BOP6,BOP8,BOPBAT
  1.  K BOPDA,BOPDFN,BOPMPRX,BOPPID,BOPPREX,BOPQ,BOPRAP,BOPRST,BOPT
  1.  K BOPVA,BOPDIV,BOPDC,BOPORDN,BOPX0,BOPVER,BOPI,BOPY,BOPX2
  1.  K BOPDDN,BOPWID,BOPIT,BOPWHO,BOP9,BOP11,BOP12
  1.  Q
  1.  ;
  1. DIV() ; EP - get Medical Center Division
  1.  N VAIP
  1.  S VAIP("D")="LAST"
  1.  D IN5^VADPT
  1.  ;Q:'$G(VAIP(5)) 0
  1.  S BOPDIV=+$$GET1^DIQ(42,+$G(VAIP(5)),.015,"I")
  1.  Q $S('$P($G(^BOP(90355,1,3,BOPDIV,0)),U,6):0,1:BOPDIV)  ;Check Accept Transactions