BOPCP2 ;IHS/ILC/ALG/CIA/PLS - ILC Queue Processor;20-Oct-2006 09:50;SM
;;1.0;AUTOMATED DISPENSING INTERFACE;**1**;Jul 26, 2005
;
EDIT ;PEP
Q:'$P($G(^BOP(90355,1,2)),U,4)
Q:'$G(PSGORD) Q:'$G(PSGP)
S BOPDFN=PSGP,BOPORDN=+PSGORD
S BOPDIV=$$DIV^BOPCAP() G:'BOPDIV END^BOPCAP
F BOPI=0:0 S BOPI=$O(^PS(55,BOPDFN,5,BOPORDN,1,BOPI)) Q:BOPI<1 D
.D INIT^BOPCAP Q:$G(BOPQ)
.S X=$P($G(^PS(55,BOPDFN,5,BOPORDN,1,BOPI,0)),U,3)
.S BOP(2.1)=$S(X:"DC",1:"NW")
.S BOP(8.2)="" ;Initial Dose
.D ORDER^BOPCAP Q:$G(BOPQ)
.N X S X=$P(BOPX0,U,3)
.S BOP(8.1)=$G(^PS(51.2,+X,0)) ;Med Route
.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
.S BOP(8.3)=$P($G(^PS(55,BOPDFN,5,BOPORDN,0)),U,16)
.S BOP8=BOP(8.1)_U_BOP(8.2)_U_BOP(8.3)
.S ^BOP(90355.1,BOPDA,8)=BOP8
.D FLAG^BOPCAP
G END^BOPCAP
;
DIAGTXT ; patient free text diag change
Q:'$P($G(^BOP(90355,1,2)),U)
Q:'$P($G(^BOP(90355,1,1)),U,2) ; send free text diag
D GET(3)
G END
;
ICD9 ; get primary icd9 for patient
N A
Q:'$P($G(^BOP(90355,1,1)),U,3) ; send discharge icd9 primary
S A=$S($D(PTF):PTF,1:DGPTF),B=$G(DFN)
Q:'$P($G(^BOP(90355,1,2)),U)
S A=$G(^DGPT(BOPDPTF,"M",BOPDPTI,0)),A=$P(A,U,5) Q:'A
I $$VERSION^XPDUTL("BCSV") D
.S A=$$ICDDX^ICDCODE(A)
.S BOP14=$P(A,U,2)_U_$P(A,U,4)
E D
.S A=$G(^ICD9(A,0)) Q:'A
.S BOP14=$P(A,U,1)_U_$P(A,U,3)
S BOP14=BOP14_U_$$DT^BOPCAP
D GET(5)
G END
ALLERGY ; patient allergy info change
Q:'$P($G(^BOP(90355,1,2)),U)
D GET(4)
G END
;
HTWT(BOPHTWT) ; patient height and weight from GMRBOP2
Q:'$P($G(^BOP(90355,1,2)),U)
D GET((BOPHTWT-7))
G END
;
GET(BOPDO) ; build the various A08 strings
I '$G(DFN) G GETQ
S BOPDFN=DFN D INIT^BOPCAP I $G(BOPQ) G GETQ
S BOPWHO=$$INTFACE^BOPTU(1)
W !,"...updating "_$S(BOPWHO="O":"Omnicell",1:"Pyxis")_" data base..."
D PID^BOPCP,PV1^BOPCP
I BOPDO=1 D OBXH^BOPCP
I BOPDO=2 D OBXW^BOPCP
I BOPDO=3 D DG1^BOPCP I BOP12="" G GETQ
I BOPDO=4 D AL1^BOPCP
N VAIP,VAROOT S VAIP("D")="LAST",VAROOT="BOPVA"
D IN5^VADPT K VAROOT,VAIP("D")
S BOP(.02)="A08" S BOP(.03)=$$DT^BOPCAP
S BOP(.04)="ADT" ;Message Type
S BOP(.21)=BOPDO
S X=$P($G(BOPVA(5)),U) I 'X G GETQ
S BOPDIV=$$DIV^BOPCAP G:'BOPDIV GETQ
; puts xaction in 90355.1 for xmission
K BOPQ D MSH^BOPCAP G:$G(BOPQ) GETQ D FLAG^BOPCAP
W "done"
GETQ Q
;
END G END^BOPCAP
;
TEST W !," XXXX ",!
Q
;
BOPCP2 ;IHS/ILC/ALG/CIA/PLS - ILC Queue Processor;20-Oct-2006 09:50;SM
+1 ;;1.0;AUTOMATED DISPENSING INTERFACE;**1**;Jul 26, 2005
+2 ;
EDIT ;PEP
+1 IF '$PIECE($GET(^BOP(90355,1,2)),U,4)
QUIT
+2 IF '$GET(PSGORD)
QUIT
IF '$GET(PSGP)
QUIT
+3 SET BOPDFN=PSGP
SET BOPORDN=+PSGORD
+4 SET BOPDIV=$$DIV^BOPCAP()
IF 'BOPDIV
GOTO END^BOPCAP
+5 FOR BOPI=0:0
SET BOPI=$ORDER(^PS(55,BOPDFN,5,BOPORDN,1,BOPI))
IF BOPI<1
QUIT
Begin DoDot:1
+6 DO INIT^BOPCAP
IF $GET(BOPQ)
QUIT
+7 SET X=$PIECE($GET(^PS(55,BOPDFN,5,BOPORDN,1,BOPI,0)),U,3)
+8 SET BOP(2.1)=$SELECT(X:"DC",1:"NW")
+9 ;Initial Dose
SET BOP(8.2)=""
+10 DO ORDER^BOPCAP
IF $GET(BOPQ)
QUIT
+11 NEW X
SET X=$PIECE(BOPX0,U,3)
+12 ;Med Route
SET BOP(8.1)=$GET(^PS(51.2,+X,0))
+13 ;DUG 1/30/03
SET BOP(8.1)=$SELECT($LENGTH($PIECE(BOP(8.1),U))'>10:$PIECE(BOP(8.1),U),1:$PIECE(BOP(8.1),U,3))
+14 SET BOP(8.3)=$PIECE($GET(^PS(55,BOPDFN,5,BOPORDN,0)),U,16)
+15 SET BOP8=BOP(8.1)_U_BOP(8.2)_U_BOP(8.3)
+16 SET ^BOP(90355.1,BOPDA,8)=BOP8
+17 DO FLAG^BOPCAP
End DoDot:1
+18 GOTO END^BOPCAP
+19 ;
DIAGTXT ; patient free text diag change
+1 IF '$PIECE($GET(^BOP(90355,1,2)),U)
QUIT
+2 ; send free text diag
IF '$PIECE($GET(^BOP(90355,1,1)),U,2)
QUIT
+3 DO GET(3)
+4 GOTO END
+5 ;
ICD9 ; get primary icd9 for patient
+1 NEW A
+2 ; send discharge icd9 primary
IF '$PIECE($GET(^BOP(90355,1,1)),U,3)
QUIT
+3 SET A=$SELECT($DATA(PTF):PTF,1:DGPTF)
SET B=$GET(DFN)
+4 IF '$PIECE($GET(^BOP(90355,1,2)),U)
QUIT
+5 SET A=$GET(^DGPT(BOPDPTF,"M",BOPDPTI,0))
SET A=$PIECE(A,U,5)
IF 'A
QUIT
+6 IF $$VERSION^XPDUTL("BCSV")
Begin DoDot:1
+7 SET A=$$ICDDX^ICDCODE(A)
+8 SET BOP14=$PIECE(A,U,2)_U_$PIECE(A,U,4)
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 SET A=$GET(^ICD9(A,0))
IF 'A
QUIT
+11 SET BOP14=$PIECE(A,U,1)_U_$PIECE(A,U,3)
End DoDot:1
+12 SET BOP14=BOP14_U_$$DT^BOPCAP
+13 DO GET(5)
+14 GOTO END
ALLERGY ; patient allergy info change
+1 IF '$PIECE($GET(^BOP(90355,1,2)),U)
QUIT
+2 DO GET(4)
+3 GOTO END
+4 ;
HTWT(BOPHTWT) ; patient height and weight from GMRBOP2
+1 IF '$PIECE($GET(^BOP(90355,1,2)),U)
QUIT
+2 DO GET((BOPHTWT-7))
+3 GOTO END
+4 ;
GET(BOPDO) ; build the various A08 strings
+1 IF '$GET(DFN)
GOTO GETQ
+2 SET BOPDFN=DFN
DO INIT^BOPCAP
IF $GET(BOPQ)
GOTO GETQ
+3 SET BOPWHO=$$INTFACE^BOPTU(1)
+4 WRITE !,"...updating "_$SELECT(BOPWHO="O":"Omnicell",1:"Pyxis")_" data base..."
+5 DO PID^BOPCP
DO PV1^BOPCP
+6 IF BOPDO=1
DO OBXH^BOPCP
+7 IF BOPDO=2
DO OBXW^BOPCP
+8 IF BOPDO=3
DO DG1^BOPCP
IF BOP12=""
GOTO GETQ
+9 IF BOPDO=4
DO AL1^BOPCP
+10 NEW VAIP,VAROOT
SET VAIP("D")="LAST"
SET VAROOT="BOPVA"
+11 DO IN5^VADPT
KILL VAROOT,VAIP("D")
+12 SET BOP(.02)="A08"
SET BOP(.03)=$$DT^BOPCAP
+13 ;Message Type
SET BOP(.04)="ADT"
+14 SET BOP(.21)=BOPDO
+15 SET X=$PIECE($GET(BOPVA(5)),U)
IF 'X
GOTO GETQ
+16 SET BOPDIV=$$DIV^BOPCAP
IF 'BOPDIV
GOTO GETQ
+17 ; puts xaction in 90355.1 for xmission
+18 KILL BOPQ
DO MSH^BOPCAP
IF $GET(BOPQ)
GOTO GETQ
DO FLAG^BOPCAP
+19 WRITE "done"
GETQ QUIT
+1 ;
END GOTO END^BOPCAP
+1 ;
TEST WRITE !," XXXX ",!
+1 QUIT
+2 ;
