BOPCP ;IHS/ILC/ALG/CIA/PLS - Capture and File Data;27-Nov-2006 11:10;SM;
;;1.0;AUTOMATED DISPENSING INTERFACE;**1,2**;Jul 26, 2005
;Called from ^BOPCAP
;Modified - IHS/MSC/PLS - 11/20/06 - Line AL1+10 - Added set of zero node for allergies
; Line AL1S+1 - Added logic to set "B" xref on BOP11
PID ;EP - Get PID Segment data
D DEM^VADPT,ADD^VADPT
S BOP(1.13)=$P($G(^DPT(BOPDFN,.13)),U,2)
;If PIMS 5.3 is installed use VA("PID" for Chart Number - IHS/CIA/PLS - 01/20/05
I $$VERSION^XPDUTL("DG")<5.3 D
.S BOP1=BOPDFN_U_BOPDFN_U_VADM(1)_U_$P(VADM(3),U)_U_$P(VADM(5),U)_U_$P(VADM(8),U)_U_VAPA(1)_U_VAPA(4)_U_$P(VAPA(5),U,2)_U_VAPA(6)_U_BOPIT_U_VAPA(8)_U_BOP(1.13)_U_$P(VADM(11),U)_U_$P(VADM(2),U) Q
E D
.S BOP1=BOPDFN_U_BOPDFN_U_VADM(1)_U_$P(VADM(3),U)_U_$P(VADM(5),U)_U_$P(VADM(8),U)_U_VAPA(1)_U_VAPA(4)_U_$P(VAPA(5),U,2)_U_VAPA(6)_U_BOPIT_U_VAPA(8)_U_BOP(1.13)_U_$G(VA("PID"))_U_$P(VADM(2),U) Q
;
PV1 ;EP - Get PV1 Segment data
K VAIP("D") S VAROOT="BOPVA" D IN5^VADPT K VAROOT
S BOP(10.2)=$P($G(BOPVA(5)),U,2) ;Nursing Unit
S BOPWID=$P($G(BOPVA(5)),U) ;Ward IEN
S BOP(10.3)=$P($G(BOPVA(6)),U,2) ;Room-Bed
S BOP(10.4)=$P($G(BOPVA(18)),U,2) ;Attending Doctor
S BOP(10.41)=$P($G(BOPVA(7)),U,2) ; consulting doc added
S BOP(10.5)="" ;Hospital Service
S BOP(10.6)=$P($G(BOPVA(13,1)),U) ;Admit Date/Time
S BOP(10.1)=$S($G(BOPVA(1)):"I",1:"O") ;Patient Status
; S BOP10=BOP(10.1)_U_BOP(10.2)_U_BOP(10.3)_U_BOP(10.4)_U_U_BOP(10.6)_U_U Q
S BOP10=BOP(10.1)_U_BOP(10.2)_U_BOP(10.3)_U_BOP(10.4)_U_U_BOP(10.6)_U_U
S $P(BOP10,U,20)=BOP(10.41)
Q
;
RXE ;EP - Get RXE, RXR, ZRX Segment Data
S BOPX0=^PS(55,BOPDFN,5,BOPORDN,0),BOPX2=^(2)
S BOP(3.1)=$P(BOPX2,U) ;Schedule (Q/T Frequency-HL7)
S BOP(3.2)=""
S BOP(3.3)=$P(BOPX2,U,2) ;Start Date/Time
I $P(BOP(3.3),".",2)=24 S $P(BOP(3.3),".",2)=2359
S BOP(3.4)=$P(BOPX2,U,4) ;Stop Date/Time
I $P(BOP(3.4),".",2)=24 S $P(BOP(3.4),".",2)=2359
N X S X=$P($G(^PS(55,BOPDFN,5,BOPORDN,0)),U,7)
S BOP(3.5)=X ;QT Order Type
S BOP(3.6)=""
S BOP(3.7)=$P(BOPX2,U,5) ;Admin Times
N I S BOP3="" F I=3.1:.1:3.7 S BOP3=BOP3_BOP(I)_U
S X=$G(^PS(55,BOPDFN,5,BOPORDN,1,BOPI,0))
S BOP(4.1)=$P(X,U) ;Dispense Drug (IEN)
S BOPDDN=BOP(4.1)
S BOP(4.2)=$P($G(^PSDRUG(+BOP(4.1),0)),U)
S A="",A=$$VER^BOPCAP("PSJ")
S BOP(4.3)=$P($G(^PS(55,BOPDFN,5,BOPORDN,($S($E(A,1)=5:".2",1:".1")))),U,2)
;S BOP(4.3)=""
S BOP4=BOP(4.1)_U_BOP(4.2)_U_BOP(4.3)
S BOP5=U_$P(X,U,2) ;Dispense Amount-HL7
S BOP6=U_$P($G(^PS(55,BOPDFN,5,BOPORDN,6)),U) ;Special instruction
Q
OBXH ;EP - Get OBX height and weight Data
S BOP(9.1)=$$VITCHT^BOPTU(+$P($$VITAL^BOPTU(DFN,"HT"),U,2))
S $P(BOP9,U,1)=BOP(9.1)
Q
OBXW ;EP - get the patient weight
S BOP(9.2)=$$VITCWT^BOPTU(+$P($$VITAL^BOPTU(DFN,"WT"),U,2))
S $P(BOP9,U,2)=BOP(9.2)
Q
DG1 ;EP - get free text diag (Dx)
S BOP12=$G(BOPVA(9))
Q
AL1 ;EP - get allergy info
N GMRA,GMRAL,BOPN K GMRAL,BOP11,BOPN
S GMRAL=""
S BOPMAL1=$P($G(^BOP(90355,1,4)),U,4)
S BOPN=0
S GMRA="1^0^111" D EN1^GMRADPT
I GMRAL="" D ; Check for patient not asked
.S B="UNKNOWN^" D AL1S
E I 'GMRAL D ; Check for nka
.S B="NKA^" D AL1S
E D ;loop thru allergies
.S A=0 F S A=$O(GMRAL(A)) Q:'A S B=$P(GMRAL(A),U,9),OK=0 D D:OK AL1S
..I +B=BOPMAL1!(B="") D Q
...S B=$P(GMRAL(A),U,2)_U,OK=1
..I $P(B,";",1)'=""&($P(B,";",2)'="") D Q
...S C=U_$P(B,";",2)_+B_",0)"
...S D=$G(@C),B=$P(D,U,1)_U_+B,OK=1
I $D(BOP11) D
.S BOP11(0)="^90355.111A^"_BOP11(0)_U_BOP11(0)
Q
AL1N ; check for nka
S A="",A=$G(^GMR(120.86,DFN,0)) I A'=""&($P(A,U,2)=0) S BOPN=0,B="NKA^" D AL1S
K GMRAL,GMRA,BOPN
Q
AL1S S BOPN=BOPN+1,BOP11(0)=BOPN,BOP11(BOPN,0)=B
S BOP11("B",$P(B,U),BOPN)=""
Q
ORC ;EP - Get ORC Segment Data
S BOP(2.2)=+$G(BOPORDN) ;Order Number
N X S X=$G(^PS(55,BOPDFN,5,BOP(2.2),0))
S BOP(2.3)=$P(X,U,9) ;Order Status
N A S A=BOP(2.3),BOP(2.3)=$S(A="A":"IP",(A="D"!(A="DE")!(A="DR")):"DC",A="H":"HD",1:"")
S (BOP(2.4))=$P(X,U,16) ;Login Date/Time
S BOP(2.7)=+$P(X,U,2),BOP(2.93)=BOP(2.7) ;Provider IEN
S BOP(2.7)=$P($G(^VA(200,BOP(2.7),0)),U) ;Provider
S X=$G(^PS(55,BOPDFN,5,BOP(2.2),4))
S BOP(2.5)=+$P(X,U,7),BOP(2.91)=BOP(2.5),BOP(2.5)=$P($G(^VA(200,BOP(2.5),0)),U) ;Clerk
S BOP(2.6)=+$P(X,U,3),BOP(2.92)=BOP(2.6),BOP(2.6)=$P($G(^VA(200,BOP(2.6),0)),U) ;Pharmacist
S X=$G(^PS(55,BOPDFN,5,BOPORDN,1,BOPI,0))
S BOP(2.8)=BOP(2.2)_"-"_$P(X,U)
N I S BOP2="" F I=2.1:.1:2.8 S A=$G(BOP(I)),BOP2=BOP2_A_U
F I=2.91:.01:2.99 S A=$G(BOP(I)),BOP2=BOP2_A_"-" I I=2.99 S BOP2=BOP2_U
K I,A
Q
BOPCP ;IHS/ILC/ALG/CIA/PLS - Capture and File Data;27-Nov-2006 11:10;SM;
+1 ;;1.0;AUTOMATED DISPENSING INTERFACE;**1,2**;Jul 26, 2005
+2 ;Called from ^BOPCAP
+3 ;Modified - IHS/MSC/PLS - 11/20/06 - Line AL1+10 - Added set of zero node for allergies
+4 ; Line AL1S+1 - Added logic to set "B" xref on BOP11
PID ;EP - Get PID Segment data
+1 DO DEM^VADPT
DO ADD^VADPT
+2 SET BOP(1.13)=$PIECE($GET(^DPT(BOPDFN,.13)),U,2)
+3 ;If PIMS 5.3 is installed use VA("PID" for Chart Number - IHS/CIA/PLS - 01/20/05
+4 IF $$VERSION^XPDUTL("DG")<5.3
Begin DoDot:1
+5 SET BOP1=BOPDFN_U_BOPDFN_U_VADM(1)_U_$PIECE(VADM(3),U)_U_$PIECE(VADM(5),U)_U_$PIECE(VADM(8),U)_U_VAPA(1)_U_VAPA(4)_U_$PIECE(VAPA(5),U,2)_U_VAPA(6)_U_BOPIT_U_VAPA(8)_U_BOP(1.13)_U_$PIECE(VADM(11),U)_U_$PIECE(VADM(2),U)
QUIT
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 SET BOP1=BOPDFN_U_BOPDFN_U_VADM(1)_U_$PIECE(VADM(3),U)_U_$PIECE(VADM(5),U)_U_$PIECE(VADM(8),U)_U_VAPA(1)_U_VAPA(4)_U_$PIECE(VAPA(5),U,2)_U_VAPA(6)_U_BOPIT_U_VAPA(8)_U_BOP(1.13)_U_$GET(VA("PID"))_U_$PIECE(VADM(2),U)
QUIT
End DoDot:1
+8 ;
PV1 ;EP - Get PV1 Segment data
+1 KILL VAIP("D")
SET VAROOT="BOPVA"
DO IN5^VADPT
KILL VAROOT
+2 ;Nursing Unit
SET BOP(10.2)=$PIECE($GET(BOPVA(5)),U,2)
+3 ;Ward IEN
SET BOPWID=$PIECE($GET(BOPVA(5)),U)
+4 ;Room-Bed
SET BOP(10.3)=$PIECE($GET(BOPVA(6)),U,2)
+5 ;Attending Doctor
SET BOP(10.4)=$PIECE($GET(BOPVA(18)),U,2)
+6 ; consulting doc added
SET BOP(10.41)=$PIECE($GET(BOPVA(7)),U,2)
+7 ;Hospital Service
SET BOP(10.5)=""
+8 ;Admit Date/Time
SET BOP(10.6)=$PIECE($GET(BOPVA(13,1)),U)
+9 ;Patient Status
SET BOP(10.1)=$SELECT($GET(BOPVA(1)):"I",1:"O")
+10 ; S BOP10=BOP(10.1)_U_BOP(10.2)_U_BOP(10.3)_U_BOP(10.4)_U_U_BOP(10.6)_U_U Q
+11 SET BOP10=BOP(10.1)_U_BOP(10.2)_U_BOP(10.3)_U_BOP(10.4)_U_U_BOP(10.6)_U_U
+12 SET $PIECE(BOP10,U,20)=BOP(10.41)
+13 QUIT
+14 ;
RXE ;EP - Get RXE, RXR, ZRX Segment Data
+1 SET BOPX0=^PS(55,BOPDFN,5,BOPORDN,0)
SET BOPX2=^(2)
+2 ;Schedule (Q/T Frequency-HL7)
SET BOP(3.1)=$PIECE(BOPX2,U)
+3 SET BOP(3.2)=""
+4 ;Start Date/Time
SET BOP(3.3)=$PIECE(BOPX2,U,2)
+5 IF $PIECE(BOP(3.3),".",2)=24
SET $PIECE(BOP(3.3),".",2)=2359
+6 ;Stop Date/Time
SET BOP(3.4)=$PIECE(BOPX2,U,4)
+7 IF $PIECE(BOP(3.4),".",2)=24
SET $PIECE(BOP(3.4),".",2)=2359
+8 NEW X
SET X=$PIECE($GET(^PS(55,BOPDFN,5,BOPORDN,0)),U,7)
+9 ;QT Order Type
SET BOP(3.5)=X
+10 SET BOP(3.6)=""
+11 ;Admin Times
SET BOP(3.7)=$PIECE(BOPX2,U,5)
+12 NEW I
SET BOP3=""
FOR I=3.1:.1:3.7
SET BOP3=BOP3_BOP(I)_U
+13 SET X=$GET(^PS(55,BOPDFN,5,BOPORDN,1,BOPI,0))
+14 ;Dispense Drug (IEN)
SET BOP(4.1)=$PIECE(X,U)
+15 SET BOPDDN=BOP(4.1)
+16 SET BOP(4.2)=$PIECE($GET(^PSDRUG(+BOP(4.1),0)),U)
+17 SET A=""
SET A=$$VER^BOPCAP("PSJ")
+18 SET BOP(4.3)=$PIECE($GET(^PS(55,BOPDFN,5,BOPORDN,($SELECT($EXTRACT(A,1)=5:".2",1:".1")))),U,2)
+19 ;S BOP(4.3)=""
+20 SET BOP4=BOP(4.1)_U_BOP(4.2)_U_BOP(4.3)
+21 ;Dispense Amount-HL7
SET BOP5=U_$PIECE(X,U,2)
+22 ;Special instruction
SET BOP6=U_$PIECE($GET(^PS(55,BOPDFN,5,BOPORDN,6)),U)
+23 QUIT
OBXH ;EP - Get OBX height and weight Data
+1 SET BOP(9.1)=$$VITCHT^BOPTU(+$PIECE($$VITAL^BOPTU(DFN,"HT"),U,2))
+2 SET $PIECE(BOP9,U,1)=BOP(9.1)
+3 QUIT
OBXW ;EP - get the patient weight
+1 SET BOP(9.2)=$$VITCWT^BOPTU(+$PIECE($$VITAL^BOPTU(DFN,"WT"),U,2))
+2 SET $PIECE(BOP9,U,2)=BOP(9.2)
+3 QUIT
DG1 ;EP - get free text diag (Dx)
+1 SET BOP12=$GET(BOPVA(9))
+2 QUIT
AL1 ;EP - get allergy info
+1 NEW GMRA,GMRAL,BOPN
KILL GMRAL,BOP11,BOPN
+2 SET GMRAL=""
+3 SET BOPMAL1=$PIECE($GET(^BOP(90355,1,4)),U,4)
+4 SET BOPN=0
+5 SET GMRA="1^0^111"
DO EN1^GMRADPT
+6 ; Check for patient not asked
IF GMRAL=""
Begin DoDot:1
+7 SET B="UNKNOWN^"
DO AL1S
End DoDot:1
+8 ; Check for nka
IF '$TEST
IF 'GMRAL
Begin DoDot:1
+9 SET B="NKA^"
DO AL1S
End DoDot:1
+10 ;loop thru allergies
IF '$TEST
Begin DoDot:1
+11 SET A=0
FOR
SET A=$ORDER(GMRAL(A))
IF 'A
QUIT
SET B=$PIECE(GMRAL(A),U,9)
SET OK=0
Begin DoDot:2
+12 IF +B=BOPMAL1!(B="")
Begin DoDot:3
+13 SET B=$PIECE(GMRAL(A),U,2)_U
SET OK=1
End DoDot:3
QUIT
+14 IF $PIECE(B,";",1)'=""&($PIECE(B,";",2)'="")
Begin DoDot:3
+15 SET C=U_$PIECE(B,";",2)_+B_",0)"
+16 SET D=$GET(@C)
SET B=$PIECE(D,U,1)_U_+B
SET OK=1
End DoDot:3
QUIT
End DoDot:2
IF OK
DO AL1S
End DoDot:1
+17 IF $DATA(BOP11)
Begin DoDot:1
+18 SET BOP11(0)="^90355.111A^"_BOP11(0)_U_BOP11(0)
End DoDot:1
+19 QUIT
AL1N ; check for nka
+1 SET A=""
SET A=$GET(^GMR(120.86,DFN,0))
IF A'=""&($PIECE(A,U,2)=0)
SET BOPN=0
SET B="NKA^"
DO AL1S
+2 KILL GMRAL,GMRA,BOPN
+3 QUIT
AL1S SET BOPN=BOPN+1
SET BOP11(0)=BOPN
SET BOP11(BOPN,0)=B
+1 SET BOP11("B",$PIECE(B,U),BOPN)=""
+2 QUIT
ORC ;EP - Get ORC Segment Data
+1 ;Order Number
SET BOP(2.2)=+$GET(BOPORDN)
+2 NEW X
SET X=$GET(^PS(55,BOPDFN,5,BOP(2.2),0))
+3 ;Order Status
SET BOP(2.3)=$PIECE(X,U,9)
+4 NEW A
SET A=BOP(2.3)
SET BOP(2.3)=$SELECT(A="A":"IP",(A="D"!(A="DE")!(A="DR")):"DC",A="H":"HD",1:"")
+5 ;Login Date/Time
SET (BOP(2.4))=$PIECE(X,U,16)
+6 ;Provider IEN
SET BOP(2.7)=+$PIECE(X,U,2)
SET BOP(2.93)=BOP(2.7)
+7 ;Provider
SET BOP(2.7)=$PIECE($GET(^VA(200,BOP(2.7),0)),U)
+8 SET X=$GET(^PS(55,BOPDFN,5,BOP(2.2),4))
+9 ;Clerk
SET BOP(2.5)=+$PIECE(X,U,7)
SET BOP(2.91)=BOP(2.5)
SET BOP(2.5)=$PIECE($GET(^VA(200,BOP(2.5),0)),U)
+10 ;Pharmacist
SET BOP(2.6)=+$PIECE(X,U,3)
SET BOP(2.92)=BOP(2.6)
SET BOP(2.6)=$PIECE($GET(^VA(200,BOP(2.6),0)),U)
+11 SET X=$GET(^PS(55,BOPDFN,5,BOPORDN,1,BOPI,0))
+12 SET BOP(2.8)=BOP(2.2)_"-"_$PIECE(X,U)
+13 NEW I
SET BOP2=""
FOR I=2.1:.1:2.8
SET A=$GET(BOP(I))
SET BOP2=BOP2_A_U
+14 FOR I=2.91:.01:2.99
SET A=$GET(BOP(I))
SET BOP2=BOP2_A_"-"
IF I=2.99
SET BOP2=BOP2_U
+15 KILL I,A
+16 QUIT
