BOPOBS ;IHS/ILC/ALG/CIA/PLS - Admits, Check OP By Location;03-Apr-2007 13:35;SM
;;1.0;AUTOMATED DISPENSING INTERFACE;**1,3**;Jul 26, 2005
;
;CHECKIN
;
CHECKIN ;EP
Q:'$G(DFN) S BOPDFN=DFN
;
;BOPOLOC = Has 3 pieces as in "AEC^ER TREATMENT"
;$P(BOPOLOC,U) = name of outpatient location entered by user.
;$P(BOPOLOC,U,2) = OUTPATIENT LOCATION name (from .01 field of
; field 10 [multiple] of the BOP Site Parameters).
;$P(BOPOLOC,U,3) = OP SEND LOCATION (field 1 of the OUTPATIENT
; LOCATION multiple above)
;
Q:'$P($G(^BOP(90355,1,2)),U) ;is adt active
Q:'$P($G(^BOP(90355,1,2)),U,6) ; is send outpatient adt active
;
I '$D(BOPOLOC)#10 S BOPOLOC=""
;
;BOPPDIV=Pointer to file Site PArameters for Hospital Division
; field 3 = receiving facility
;
S U="^",BOPPDIV=$$PRIM^VASITE()
I BOPPDIV S BOPPDIV=$O(^BOP(90355,1,3,"B",BOPPDIV,0))
E S BOPPDIV=$O(^BOP(90355,1,3,0))
;
D INIT^BOPCAP Q:$D(BOPQ)
D PID^BOPCP
I D'=5 S BOP(.02)="A01",BOP(.04)="ADT"
E S BOP(.02)="A03",BOP(.04)="ADT"
; set bop(.03)=bopadm, which is x from ihs code with check in time
S %DT="ST",X="N" D ^%DT S BOP(.03)=$G(BOPADM)
;
;$P(BOP10,u,2) = the outpatient 'ward'. If there is a value in
;the "Default Outpatient Location" field of the BOP Site Parameters
;file, that is used. Otherwise, the OP SEND LOCATION that belongs to
;the OUTPATIENT LOCATION is used. Finally, 'AEC' is the default.
;Piece 11 is the Patient Type
;
S BOPSALL="N"
I $P($G(BOPLD),U,5)=1 S BOPSALL="Y"
S BOP10=""
I BOP10="",$L($P(BOPOLOC,U,2)) S BOP10="O^"_$P(BOPOLOC,U,2)
I BOP10="" S BOP10="O^AEC"
;
;Call to create HL7 Message in BOP Queue file
K BOPQ S BOPDIV=BOPPDIV
D MSH^BOPCAP Q:$G(BOPQ)
;
;SET READY FLAG
S $P(^BOP(90355.1,BOPDA,0),U,10)=0
S ^BOP(90355.1,"AS",0,BOPDA)=""
N DA,DIK S DA=BOPDA,DIK="^BOP(90355.1," D IX1^DIK K DA,DIK
I +$G(^BOPDTG(1))=1 D
.S A=$G(^BOPDTG(1,+$H,DFN,0)) Q:'A S B=$G(^BOPDTG(1,+$H,DFN,A)),$P(B,"^",3)=BOPDA
.S ^BOPDTG(1,+$H,DFN,A)=B
.Q
Q
BYLOC ;This entry point is for use in outpatient environments.
D JOB^BOPOBS
;Check against BOP Site Parameters.
;If there is no table do not invoke Interface
;Otherwise send patients to the Interface if the location contains
; a match to any character string in field 10 (multiple) and
; use the "Send Location" field as the nursing unit.
;
N L,X,Y,Z,K
;
;Z=Default Location
;BOPOLOC=.01 field of Patient Location file (44)
;
N BOPLD S BOPLD=$G(^BOP(90355,1,"SITE"))
; this code is maintained for backward compatability
;
I '$G(BOPOLOC) G BYNEW
S K=$P($G(^SC(BOPOLOC,0)),U)
S X=0,L=0
F S X=$O(^BOP(90355,1,"OPLOC",X)) Q:'X S Y=^(X,0) D Q:L
.Q:K'[$P(Y,U)
.S $P(K,U,2,3)=$P(Y,U,1,2),L=1
I L=1 S BOPOLOC=K G CHECKIN
;
BYNEW ; skip around point for BOPOLOC
;
; new lookup code
;
I +$G(BOPOLOC)<1 S:$P(BOPLD,U,5) BOPOLOC=$P(BOPLD,U,6) G BYSEND
I +$G(BOPOLOC)<1 Q
S A=$O(^BOP(90355,1,"OPLOC","AC",+BOPOLOC,"")) I 'A G:$P(BOPLD,U,5) BYSEND Q
S Y=$G(^BOP(90355,1,"OPLOC",A,0)) I $P(Y,U,3)'=+BOPOLOC G:$P(BOPLD,U,5) BYSEND Q
S A=$P($G(^SC(+BOPOLOC,0)),U,1),$P(BOPOLOC,U,2)=A,$P(BOPOLOC,U,3)=$P(Y,U,2)
I $P(BOPOLOC,U,3)="" S $P(BOPOLOC,U,3)=$P(BOPLD,U,4)
G CHECKIN
;
BYSEND ;if send all is marked and location is not in 90355 file
I +$G(BOPOLOC)<1 Q
S A=$P($G(^SC(+BOPOLOC,0)),U,1),$P(BOPOLOC,U,2)=A,$P(BOPOLOC,U,3)=$P(BOPLD,U,4)
G CHECKIN
Q
; set up track file by date,dfn in order
JOB ; EP
I +$G(^BOPDTG(1))'=1 Q
I +$G(DFN)<1 Q
S A=$G(^BOPDTG(1,+$H,+$G(DFN),0)),A=A+1,^BOPDTG(1,+$H,+$G(DFN),0)=A
S ^BOPDTG(1,+$H,+$G(DFN),A)=$G(BOPOLOC)_"^"_$H
Q
SDAM ;EP - entry from the SDAM main event
; SDAMEVT = type of event
; 1=make appointment (unscheduled)
; 4=check in
; 8=disposition an application
; 9=disposition edit
; SDCL = clinic location (pointer to ^SC file 44
; DFN patient internal number
N BOPLIEN,QT,D
S QT=0
I $G(SDAMEVT)="" S SDAMEVT=$S($G(SDAPTYP):4,$G(ASD)=2:4,1:1)
I $G(SDCL)="" S SDCL=$S($G(SDSC):SDSC,1:$P(SSC,U,1))
S BOPADM="" S BOPADM=$G(SDPR) I BOPADM=""&($G(X)'="") S BOPADM=X ; clinic appt time
I $G(X)'="" S BOPADM=X
I $$GET1^DIQ(90355,1,316.5,"I") D Q:QT
.S D=SDAMEVT I D'=1&(D'=4)&(D'=5)&(D'=8)&(D'=9) K D S QT=1 Q
E D Q:QT
.S D=SDAMEVT I (D'=4)&(D'=5)&(D'=8)&(D'=9) K D S QT=1 Q
N I,BOPOLOC,BOPDFN,DA,X,Y,A,B,C,BOPPLD,DIC,DIK,VADM,VAPA,%DT
S BOPDFN=$G(DFN),BOPOLOC=$G(SDCL) N DFN S DFN=BOPDFN
I $G(DFN)=0!($G(DFN)="") D Q:$G(DFN)=""
.I $G(SDFN)'="" S DFN=SDFN D Q
..I $D(^XTMP("BOPDISP",DUZ,SDFN)) K ^XTMP("BOPDISP",DUZ,SDFN) Q
.S DFN=$O(^XTMP("BOPDISP",DUZ,DFN)) Q:DFN="" S BOPDFN=DFN K ^XTMP("BOPDISP",DUZ,DFN)
I BOPOLOC="" D
.S BOPREC="" S BOPREC=$O(^BOP(90355,0)) Q:BOPREC=""
.S BOPOLOC=$P(^BOP(90355,BOPREC,0),U,14)
Q:$G(BOPOLOC)=""
D BYLOC
K BOPOLOC,BOPDFN,DFN,DA,X,Y,A,B,C,BOPPLD,DIC,DIK
K VADM,BOP,BOP0,BOP1,BOP10,VAPA,BOPBAT,BOPDA,VAERR,BOPDIV
K BOPIT,BOPPDIV,BOPRAP,BOPVER,BOPWHO,BOPY
Q
BOPOBS ;IHS/ILC/ALG/CIA/PLS - Admits, Check OP By Location;03-Apr-2007 13:35;SM
+1 ;;1.0;AUTOMATED DISPENSING INTERFACE;**1,3**;Jul 26, 2005
+2 ;
+3 ;CHECKIN
+4 ;
CHECKIN ;EP
+1 IF '$GET(DFN)
QUIT
SET BOPDFN=DFN
+2 ;
+3 ;BOPOLOC = Has 3 pieces as in "AEC^ER TREATMENT"
+4 ;$P(BOPOLOC,U) = name of outpatient location entered by user.
+5 ;$P(BOPOLOC,U,2) = OUTPATIENT LOCATION name (from .01 field of
+6 ; field 10 [multiple] of the BOP Site Parameters).
+7 ;$P(BOPOLOC,U,3) = OP SEND LOCATION (field 1 of the OUTPATIENT
+8 ; LOCATION multiple above)
+9 ;
+10 ;is adt active
IF '$PIECE($GET(^BOP(90355,1,2)),U)
QUIT
+11 ; is send outpatient adt active
IF '$PIECE($GET(^BOP(90355,1,2)),U,6)
QUIT
+12 ;
+13 IF '$DATA(BOPOLOC)#10
SET BOPOLOC=""
+14 ;
+15 ;BOPPDIV=Pointer to file Site PArameters for Hospital Division
+16 ; field 3 = receiving facility
+17 ;
+18 SET U="^"
SET BOPPDIV=$$PRIM^VASITE()
+19 IF BOPPDIV
SET BOPPDIV=$ORDER(^BOP(90355,1,3,"B",BOPPDIV,0))
+20 IF '$TEST
SET BOPPDIV=$ORDER(^BOP(90355,1,3,0))
+21 ;
+22 DO INIT^BOPCAP
IF $DATA(BOPQ)
QUIT
+23 DO PID^BOPCP
+24 IF D'=5
SET BOP(.02)="A01"
SET BOP(.04)="ADT"
+25 IF '$TEST
SET BOP(.02)="A03"
SET BOP(.04)="ADT"
+26 ; set bop(.03)=bopadm, which is x from ihs code with check in time
+27 SET %DT="ST"
SET X="N"
DO ^%DT
SET BOP(.03)=$GET(BOPADM)
+28 ;
+29 ;$P(BOP10,u,2) = the outpatient 'ward'. If there is a value in
+30 ;the "Default Outpatient Location" field of the BOP Site Parameters
+31 ;file, that is used. Otherwise, the OP SEND LOCATION that belongs to
+32 ;the OUTPATIENT LOCATION is used. Finally, 'AEC' is the default.
+33 ;Piece 11 is the Patient Type
+34 ;
+35 SET BOPSALL="N"
+36 IF $PIECE($GET(BOPLD),U,5)=1
SET BOPSALL="Y"
+37 SET BOP10=""
+38 IF BOP10=""
IF $LENGTH($PIECE(BOPOLOC,U,2))
SET BOP10="O^"_$PIECE(BOPOLOC,U,2)
+39 IF BOP10=""
SET BOP10="O^AEC"
+40 ;
+41 ;Call to create HL7 Message in BOP Queue file
+42 KILL BOPQ
SET BOPDIV=BOPPDIV
+43 DO MSH^BOPCAP
IF $GET(BOPQ)
QUIT
+44 ;
+45 ;SET READY FLAG
+46 SET $PIECE(^BOP(90355.1,BOPDA,0),U,10)=0
+47 SET ^BOP(90355.1,"AS",0,BOPDA)=""
+48 NEW DA,DIK
SET DA=BOPDA
SET DIK="^BOP(90355.1,"
DO IX1^DIK
KILL DA,DIK
+49 IF +$GET(^BOPDTG(1))=1
Begin DoDot:1
+50 SET A=$GET(^BOPDTG(1,+$HOROLOG,DFN,0))
IF 'A
QUIT
SET B=$GET(^BOPDTG(1,+$HOROLOG,DFN,A))
SET $PIECE(B,"^",3)=BOPDA
+51 SET ^BOPDTG(1,+$HOROLOG,DFN,A)=B
+52 QUIT
End DoDot:1
+53 QUIT
BYLOC ;This entry point is for use in outpatient environments.
+1 DO JOB^BOPOBS
+2 ;Check against BOP Site Parameters.
+3 ;If there is no table do not invoke Interface
+4 ;Otherwise send patients to the Interface if the location contains
+5 ; a match to any character string in field 10 (multiple) and
+6 ; use the "Send Location" field as the nursing unit.
+7 ;
+8 NEW L,X,Y,Z,K
+9 ;
+10 ;Z=Default Location
+11 ;BOPOLOC=.01 field of Patient Location file (44)
+12 ;
+13 NEW BOPLD
SET BOPLD=$GET(^BOP(90355,1,"SITE"))
+14 ; this code is maintained for backward compatability
+15 ;
+16 IF '$GET(BOPOLOC)
GOTO BYNEW
+17 SET K=$PIECE($GET(^SC(BOPOLOC,0)),U)
+18 SET X=0
SET L=0
+19 FOR
SET X=$ORDER(^BOP(90355,1,"OPLOC",X))
IF 'X
QUIT
SET Y=^(X,0)
Begin DoDot:1
+20 IF K'[$PIECE(Y,U)
QUIT
+21 SET $PIECE(K,U,2,3)=$PIECE(Y,U,1,2)
SET L=1
End DoDot:1
IF L
QUIT
+22 IF L=1
SET BOPOLOC=K
GOTO CHECKIN
+23 ;
BYNEW ; skip around point for BOPOLOC
+1 ;
+2 ; new lookup code
+3 ;
+4 IF +$GET(BOPOLOC)<1
IF $PIECE(BOPLD,U,5)
SET BOPOLOC=$PIECE(BOPLD,U,6)
GOTO BYSEND
+5 IF +$GET(BOPOLOC)<1
QUIT
+6 SET A=$ORDER(^BOP(90355,1,"OPLOC","AC",+BOPOLOC,""))
IF 'A
IF $PIECE(BOPLD,U,5)
GOTO BYSEND
QUIT
+7 SET Y=$GET(^BOP(90355,1,"OPLOC",A,0))
IF $PIECE(Y,U,3)'=+BOPOLOC
IF $PIECE(BOPLD,U,5)
GOTO BYSEND
QUIT
+8 SET A=$PIECE($GET(^SC(+BOPOLOC,0)),U,1)
SET $PIECE(BOPOLOC,U,2)=A
SET $PIECE(BOPOLOC,U,3)=$PIECE(Y,U,2)
+9 IF $PIECE(BOPOLOC,U,3)=""
SET $PIECE(BOPOLOC,U,3)=$PIECE(BOPLD,U,4)
+10 GOTO CHECKIN
+11 ;
BYSEND ;if send all is marked and location is not in 90355 file
+1 IF +$GET(BOPOLOC)<1
QUIT
+2 SET A=$PIECE($GET(^SC(+BOPOLOC,0)),U,1)
SET $PIECE(BOPOLOC,U,2)=A
SET $PIECE(BOPOLOC,U,3)=$PIECE(BOPLD,U,4)
+3 GOTO CHECKIN
+4 QUIT
+5 ; set up track file by date,dfn in order
JOB ; EP
+1 IF +$GET(^BOPDTG(1))'=1
QUIT
+2 IF +$GET(DFN)<1
QUIT
+3 SET A=$GET(^BOPDTG(1,+$HOROLOG,+$GET(DFN),0))
SET A=A+1
SET ^BOPDTG(1,+$HOROLOG,+$GET(DFN),0)=A
+4 SET ^BOPDTG(1,+$HOROLOG,+$GET(DFN),A)=$GET(BOPOLOC)_"^"_$HOROLOG
+5 QUIT
SDAM ;EP - entry from the SDAM main event
+1 ; SDAMEVT = type of event
+2 ; 1=make appointment (unscheduled)
+3 ; 4=check in
+4 ; 8=disposition an application
+5 ; 9=disposition edit
+6 ; SDCL = clinic location (pointer to ^SC file 44
+7 ; DFN patient internal number
+8 NEW BOPLIEN,QT,D
+9 SET QT=0
+10 IF $GET(SDAMEVT)=""
SET SDAMEVT=$SELECT($GET(SDAPTYP):4,$GET(ASD)=2:4,1:1)
+11 IF $GET(SDCL)=""
SET SDCL=$SELECT($GET(SDSC):SDSC,1:$PIECE(SSC,U,1))
+12 ; clinic appt time
SET BOPADM=""
SET BOPADM=$GET(SDPR)
IF BOPADM=""&($GET(X)'="")
SET BOPADM=X
+13 IF $GET(X)'=""
SET BOPADM=X
+14 IF $$GET1^DIQ(90355,1,316.5,"I")
Begin DoDot:1
+15 SET D=SDAMEVT
IF D'=1&(D'=4)&(D'=5)&(D'=8)&(D'=9)
KILL D
SET QT=1
QUIT
End DoDot:1
IF QT
QUIT
+16 IF '$TEST
Begin DoDot:1
+17 SET D=SDAMEVT
IF (D'=4)&(D'=5)&(D'=8)&(D'=9)
KILL D
SET QT=1
QUIT
End DoDot:1
IF QT
QUIT
+18 NEW I,BOPOLOC,BOPDFN,DA,X,Y,A,B,C,BOPPLD,DIC,DIK,VADM,VAPA,%DT
+19 SET BOPDFN=$GET(DFN)
SET BOPOLOC=$GET(SDCL)
NEW DFN
SET DFN=BOPDFN
+20 IF $GET(DFN)=0!($GET(DFN)="")
Begin DoDot:1
+21 IF $GET(SDFN)'=""
SET DFN=SDFN
Begin DoDot:2
+22 IF $DATA(^XTMP("BOPDISP",DUZ,SDFN))
KILL ^XTMP("BOPDISP",DUZ,SDFN)
QUIT
End DoDot:2
QUIT
+23 SET DFN=$ORDER(^XTMP("BOPDISP",DUZ,DFN))
IF DFN=""
QUIT
SET BOPDFN=DFN
KILL ^XTMP("BOPDISP",DUZ,DFN)
End DoDot:1
IF $GET(DFN)=""
QUIT
+24 IF BOPOLOC=""
Begin DoDot:1
+25 SET BOPREC=""
SET BOPREC=$ORDER(^BOP(90355,0))
IF BOPREC=""
QUIT
+26 SET BOPOLOC=$PIECE(^BOP(90355,BOPREC,0),U,14)
End DoDot:1
+27 IF $GET(BOPOLOC)=""
QUIT
+28 DO BYLOC
+29 KILL BOPOLOC,BOPDFN,DFN,DA,X,Y,A,B,C,BOPPLD,DIC,DIK
+30 KILL VADM,BOP,BOP0,BOP1,BOP10,VAPA,BOPBAT,BOPDA,VAERR,BOPDIV
+31 KILL BOPIT,BOPPDIV,BOPRAP,BOPVER,BOPWHO,BOPY
+32 QUIT
