- 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 ;
