BHLBPS1 ; IHS/TUCSON/DCP - HL7 - FILE VISIT/V MED FROM COTS PHARMACY ;
;;1.0;IHS SUPPORT FOR HL7 INTERFACES;;JUL 7, 1997
;
; This routine is a continuation of BHLBPS.
; It is not independently callable.
;
START ; ENTRY POINT from BHLBPS
;
N BHLBIDX,BHLEIDX,BHLMIDX,BHLBMSG,XMB,PCPRVNAM
S BHLEIDX=7 ; last non-error field on bulletin
S BHLMIDX=12 ; last error field on bulletin
S BHLBIDX=BHLEIDX ; initialize bulletin field pointer
D INIT
I BHLERR="" D @BHLACT
I $G(BHLDBUG) D LOGAPCD ; log APCDALVR array if debugging
D SENDBULL
EOJ ;KILL VARS AND EXIT
K APCDALVR,APCDANE,APCDTCDT,APCDTDAY,APCDTEXK,APCDTNTD,APCDTPRV,APCDTQTY,APCDTRX,APCDTSIG,APCDTOPR
K BHLBPSR,BHLDOB,BHLF,BHLFILE,BHLJ,BHLSEX,BHLSSN,BHLDUZ2,BHLACT,BHLXKEY
K IEN,SEX,DOB,SSN
D KILL^AUPNPAT
K C,F,I,DIC,DIE,DIK,DR,D0,DO,DI
Q
;
A ;add a new prescription
D EDIT
I BHLERR'="" Q
S APCDALVR("APCDAUTO")=""
S APCDALVR("APCDANE")=""
D ^APCDALV
I $D(APCDALVR("APCDAFLG")) S BHLERR="VISIT CREATION FAILED" Q
S APCDALVR("APCDATMP")="[APCDALVR 9000010.14 (ADD)]"
D ^APCDALVR
I $D(APCDALVR("APCDAFLG")) S BHLERR="V MED CREATION FAILED" Q
Q
;
D ;delete a v med
S DA=$O(^AUPNVMED("AXK",BHLXKEY,0)) I DA="" S BHLERR="CANNOT FIND V MED FOR DELETE",BHLEDATA="V MED = "_BHLXKEY Q
S DIK="^AUPNVMED(" D ^DIK
K DIK,DA
Q
;
E ;edit an existing v med
S DA=$O(^AUPNVMED("AXK",BHLXKEY,0)) I DA="" S BHLERR="CANNOT FIND V MED FOR EDIT",BHLEDATA="V MED = "_BHLXKEY Q
S APCDALVR("APCDVSIT")=$P(^AUPNVMED(DA,0),U,3)
S APCDALVR("APCDPAT")=$P(^AUPNVMED(DA,0),U,2)
S DIK="^AUPNVMED(" D ^DIK K DIK,DA
D EMED
Q:BHLERR'=""
S APCDALVR("APCDATMP")="[APCDALVR 9000010.14 (ADD)]"
D ^APCDALVR
I $D(APCDALVR("APCDAFLG")) S BHLERR="V MED FAILED ON EDIT" Q
Q
;
INIT ;
;check to be sure that all required pieces of data are present
;if not, set error and quit
N X,Y
K APCDALVR
I BHLBPS("MED")="" S BHLERR="MISSING MED INFO" Q
S BHLACT=$P(BHLBPS("MED"),BHLFS,6)
I "^A^E^D^"'[(U_BHLACT_U) S BHLERR="INVALID ACTION",BHLEDATA="ACTION = "_BHLACT Q
S BHLXKEY=$P(BHLBPS("MED"),BHLFS,5)
I BHLXKEY="" S BHLERR="MISSING EXTERNAL KEY" Q
Q:BHLACT="D"
I BHLBPS("PAT DEMO")="" S BHLERR="MISSING PATIENT DEMOGRAPHICS" Q
I BHLBPS("VISIT")="" S BHLERR="MISSING VISIT INFO" Q
S Y="NAME^DOB^SEX^SSN^CHART^FACILITY"
F X=1,2,3,5,6 I $P(BHLBPS("PAT DEMO"),BHLFS,X)="" S BHLERR=BHLERR_","_$P(Y,U,X)
S Y="VISIT DATE^SVC CAT^FACILITY"
F X=1:1:3 I $P(BHLBPS("VISIT"),BHLFS,X)="" S BHLERR=BHLERR_","_$P(Y,U,X)
S Y="RX NUMBER^QTY^DAYS PRESCRIBED^DISP DATE^EXTKEY^ACTION^REF^NDC^DRUG^UNITS^SIG^PROVIDER DEA#^PROVIDER NAME^RPH CODE^RPH NAME"
F X=2,3,7,8,10,13,14 I $P(BHLBPS("MED"),BHLFS,X)="" S BHLERR=BHLERR_","_$P(Y,U,X)
I $P(BHLBPS("MED"),BHLFS,11)="",$P(BHLBPS("MED"),BHLFS,12)="" S BHLERR=BHLERR_","_$P(Y,U,11)_","_$P(Y,U,12)
I BHLERR'="" S BHLERR="MISSING DATA: "_$E(BHLERR,2,$L(BHLERR))
Q
;
EDIT ;edit all passed data, check against input tx
;edit record info against input transform
D GETPAT
Q:BHLERR'=""
D EVISIT ;edit visit information and set array
D EMED ;edit v med and set up APCDALVR array
Q
;
EMED ;
N X,Y
S X=$P(BHLBPS("MED"),BHLFS,8),DIC(0)="",DIC="^PSDRUG(" D ^DIC K DIC,DA,DR
I Y=-1 S BHLBMSG="DRUG ENTRY COULD NOT BE FOUND BY NAME" D BULLETIN S X="OUTSIDE DRUG",DIC="^PSDRUG(",DIC(0)="M" D ^DIC I Y=-1 S BHLERR="OUTSIDE DRUG ENTRY NOT IN DRUG TABLE" Q
S APCDALVR("APCDTRX")="`"_+Y
I $P(Y,U,2)="OUTSIDE DRUG" S APCDALVR("APCDTNTD")=$P(BHLBPS("MED"),BHLFS,8)
; check provider, quit if error
;
D PROV Q:BHLERR'=""
;
;check sig
;
K DIC
S X=$E($P(BHLBPS("MED"),BHLFS,10),1,145)
K BHLBPSR D CHK^DIE(9000010.14,.05,"E",X,.BHLBPSR)
I BHLBPSR="^" S BHLERR="SIG FAILED INPUT TRANSFORM",BHLEDATA="SIG = "_X Q
S APCDALVR("APCDTSIG")=BHLBPSR
S BHLFILE=9000010.14 F BHLJ=2:1:5 Q:BHLERR'="" S BHLF=$P("^.06^.07^1201^1209",U,BHLJ),X=$P(BHLBPS("MED"),BHLFS,BHLJ) I X'="" K BHLBPSR D CHK^DIE(9000010.14,BHLF,"E",X,.BHLBPSR) D
.I BHLBPSR="^" S BHLERR="FIELD "_BHLF_" FAILED INPUT TRANSFORM IN V MED",BHLEDATA=X Q
.Q
Q:BHLERR'=""
S APCDALVR("APCDTQTY")=$P(BHLBPS("MED"),BHLFS,2)
S APCDALVR("APCDTDAY")=$P(BHLBPS("MED"),BHLFS,3)
S APCDALVR("APCDTCDT")=$P(BHLBPS("MED"),BHLFS,4)
S APCDALVR("APCDTEXK")=$P(BHLBPS("MED"),BHLFS,5)
Q
;
PROV ; Verify provider name/number
;
N BHL200,VKPRVDEA,PCPRVDEA,VKPRVNAM,PRVIEN,DIC,X,Y
S VKPRVDEA=$P(BHLBPS("MED"),BHLFS,11) ; pharmacy provider DEA #
S VKPRVNAM=$P(BHLBPS("MED"),BHLFS,12) ; pharmacy provider name
S BHL200=$P($G(^AUTTSITE(1,0)),U,22) ; new person file flag
;
S DIC=$S(BHL200:"^VA(200,",1:"^DIC(6,"),DIC(0)="MOZ"
S X=VKPRVNAM D ^DIC
I Y=-1 S X=VKPRVDEA D ^DIC
I Y=-1 S BHLERR="PROVIDER FROM RX SYSTEM FAILED EDIT" Q
S PRVIEN=$P(Y,U,1),PCPRVNAM=Y(0,0),PCPRVDEA=$S(BHL200:$P($G(^VA(200,PRVIEN,"PS")),U,2),1:$P(Y(0),U,3))
S APCDALVR("APCDTPRV")="`"_+PRVIEN
I VKPRVDEA="" S BHLBMSG="PROVIDER DEA# NOT PROVIDED BY RX SYSTEM" D BULLETIN Q
I PCPRVDEA="" S BHLBMSG="PROVIDER DEA# NOT FOUND IN PCC DATABASE" D BULLETIN Q
I PCPRVDEA'=VKPRVDEA S BHLERR="PROVIDER DEA# MISMATCH" Q
I VKPRVNAM="" S BHLBMSG="PROVIDER NAME NOT PROVIDED BY RX SYSTEM" D BULLETIN Q
I '$$MATCH(VKPRVNAM,PCPRVNAM) S BHLBMSG="PROVIDER NAME MISMATCH" D BULLETIN Q
Q
;
EVISIT ;
;edit passed date,facility and set APCDALVR array
S Y=$P(BHLBPS("VISIT"),BHLFS,1) I $P(Y,".",2)="" S Y=Y_"@12:00"
D CHK^DIE(9000010,.01,"E",Y,.BHLBPSR)
I BHLBPSR="^" S BHLERR="VISIT DATE FAILED INPUT TRANSFORM",BHLEDATA="VISIT DATE = "_Y Q
S APCDALVR("APCDDATE")=BHLBPSR
S Y=$P(BHLBPS("VISIT"),BHLFS,3),Y=$O(^AUTTLOC("C",Y,0))
I 'Y S BHLERR="COULD NOT LOOK UP LOCATION OF ENCOUNTER",BHLEDATA="LOCATION = "_Y Q
S APCDALVR("APCDLOC")=Y
S APCDALVR("APCDTYPE")=$S($P($G(^APCCCTRL(Y,0)),U,4)'="":$P(^APCCCTRL(Y,0),U,4),$P($G(^APCCCTRL(DUZ(2),0)),U,4)'="":$P(^APCCCTRL(DUZ(2),0),U,4),1:"I")
S APCDALVR("APCDCAT")=$P(BHLBPS("VISIT"),BHLFS,2) D CHK^DIE(9000010,.07,"E",APCDALVR("APCDCAT"),.BHLBPSR) I BHLBPSR="^" S BHLERR="SERVICE CATEGORY FAILED INPUT TRANSFORM",BHLEDATA="SERVICE CATEGORY = "_APCDALVR("APCDCAT") Q
Q
;
GETPAT ;
;get patient IEN if possible
;if fails send bulletin
;if sex,ssn,dob don't match fail
;if name not exact, send warning bulletin
N C,F,X,Y,PATDOB,PATSEX,PATSSN
S F=$P(BHLBPS("PAT DEMO"),BHLFS,6)
S F=$O(^AUTTLOC("C",F,0))
I 'F S BHLERR="FACILITY FOR HRN LOOKUP FAILED",BHLEDATA="FACILITY = "_F Q
S C=$P(BHLBPS("PAT DEMO"),BHLFS,5),BHLSEX=$P(BHLBPS("PAT DEMO"),BHLFS,3),BHLDOB=$P(BHLBPS("PAT DEMO"),BHLFS,2),BHLSSN=$P(BHLBPS("PAT DEMO"),BHLFS,4)
K DIC,DA,DR,DD,D0,DO S BHLDUZ2=DUZ(2),DUZ(2)=F,X=C,DIC="^AUPNPAT(",DIC(0)="M" D ^DIC
S DUZ(2)=BHLDUZ2 K BHLDUZ2
I Y=-1 S BHLERR="CHART NUMBER LOOKUP FAILED, CAN'T FIND PATIENT",BHLEDATA="CHART NUMBER = "_X Q
S IEN=$P(Y,U,1)
S PATDOB=$P(^DPT(IEN,0),U,3)
I BHLDOB'=PATDOB S BHLERR="DOB OF PATIENT DOES NOT MATCH",BHLEDATA="PHARMACY DOB = "_BHLDOB_", PCC DOB = "_PATDOB Q
S PATSEX=$P(^DPT(IEN,0),U,2)
I BHLSEX'="",PATSEX'="",BHLSEX'=PATSEX S BHLERR="SEX OF PATIENT DOES NOT MATCH",BHLEDATA="PHARMACY SEX = "_BHLSEX_", PCC SEX = "_PATSEX Q
S PATSSN=$P(^DPT(IEN,0),U,9)
I BHLSSN'="",PATSSN'="",BHLSSN'=PATSSN S BHLERR="SSN DOES NOT MATCH",BHLEDATA="PHARMACY SSN = "_BHLSSN_", PCC SSN = "_PATSSN Q
I '$$MATCH($P(BHLBPS("PAT DEMO"),BHLFS,1),$P(^DPT(IEN,0),U,1)) S BHLBMSG="PAT NAME FROM PHARMACY SYSTEM DOES NOT MATCH PAT REG" D BULLETIN
S APCDALVR("APCDPAT")=IEN
Q
;
MATCH(STR1,STR2) ; match up strings
;
N MIN
S MIN=$S($L(STR1)<$L(STR2):$L(STR1),1:$L(STR2))
I MIN<6 Q (STR1=STR2)
Q ($E(STR1,1,MIN)=$E(STR2,1,MIN))
;
BULLETIN ;
; add error message to bulletin - bulletin will be sent later
S BHLBIDX=BHLBIDX+1
S XMB(BHLBIDX)=BHLBMSG
Q
;
SENDBULL ;
; if debug mode, list bulletin errors on screen and quit
I $G(BHLDBUG) D K XMB Q
.W !,"Warning Bulletin:"
.I BHLBIDX=BHLEIDX W !,?3,"none" Q
.N I F I=8:1:BHLBIDX W !,?3,XMB(I)
;
; quit if nothing to send
Q:BHLBIDX=BHLEIDX
N %X,%Y,X,XMDT,XMDUZ,Y1
; bulletin name
S XMB="BHLBPS RX-PCC LINK DATA ERROR"
; PCC patient name
S XMB(1)=$S($D(IEN):$P(^DPT(IEN,0),U,1),1:"")
; pharmacy patient name
S XMB(2)=$P(BHLBPS("PAT DEMO"),BHLFS,1)
; patient chart number
S XMB(3)=$P(BHLBPS("PAT DEMO"),BHLFS,5)
; drug name
S XMB(4)=$P(BHLBPS("MED"),BHLFS,8)
; dispense date
S Y=$P(BHLBPS("MED"),BHLFS,4) X ^DD("DD") S XMB(5)=Y
; pharmacy provider - name and DEA #
S XMB(6)=$P(BHLBPS("MED"),BHLFS,12)_" "_$P(BHLBPS("MED"),BHLFS,11)
; PCC provider name
S XMB(7)=$G(PCPRVNAM)
; null out any unused parameters
F BHLBIDX=BHLBIDX+1:1:BHLMIDX S XMB(BHLBIDX)=""
S XMDUZ=.5
D ^XMB
K XMB
Q
;
LOGAPCD ; Log APCDALVR array if debugging
;
Q:'$G(BHLDBUG)
K ^TMP("BHLBPS",$J)
N I
S I="" F S I=$O(APCDALVR(I)) Q:I="" S ^TMP("BHLBPS",$J,"APCDALVR",I)=APCDALVR(I)
Q
BHLBPS1 ; IHS/TUCSON/DCP - HL7 - FILE VISIT/V MED FROM COTS PHARMACY ;
+1 ;;1.0;IHS SUPPORT FOR HL7 INTERFACES;;JUL 7, 1997
+2 ;
+3 ; This routine is a continuation of BHLBPS.
+4 ; It is not independently callable.
+5 ;
START ; ENTRY POINT from BHLBPS
+1 ;
+2 NEW BHLBIDX,BHLEIDX,BHLMIDX,BHLBMSG,XMB,PCPRVNAM
+3 ; last non-error field on bulletin
SET BHLEIDX=7
+4 ; last error field on bulletin
SET BHLMIDX=12
+5 ; initialize bulletin field pointer
SET BHLBIDX=BHLEIDX
+6 DO INIT
+7 IF BHLERR=""
DO @BHLACT
+8 ; log APCDALVR array if debugging
IF $GET(BHLDBUG)
DO LOGAPCD
+9 DO SENDBULL
EOJ ;KILL VARS AND EXIT
+1 KILL APCDALVR,APCDANE,APCDTCDT,APCDTDAY,APCDTEXK,APCDTNTD,APCDTPRV,APCDTQTY,APCDTRX,APCDTSIG,APCDTOPR
+2 KILL BHLBPSR,BHLDOB,BHLF,BHLFILE,BHLJ,BHLSEX,BHLSSN,BHLDUZ2,BHLACT,BHLXKEY
+3 KILL IEN,SEX,DOB,SSN
+4 DO KILL^AUPNPAT
+5 KILL C,F,I,DIC,DIE,DIK,DR,D0,DO,DI
+6 QUIT
+7 ;
A ;add a new prescription
+1 DO EDIT
+2 IF BHLERR'=""
QUIT
+3 SET APCDALVR("APCDAUTO")=""
+4 SET APCDALVR("APCDANE")=""
+5 DO ^APCDALV
+6 IF $DATA(APCDALVR("APCDAFLG"))
SET BHLERR="VISIT CREATION FAILED"
QUIT
+7 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.14 (ADD)]"
+8 DO ^APCDALVR
+9 IF $DATA(APCDALVR("APCDAFLG"))
SET BHLERR="V MED CREATION FAILED"
QUIT
+10 QUIT
+11 ;
D ;delete a v med
+1 SET DA=$ORDER(^AUPNVMED("AXK",BHLXKEY,0))
IF DA=""
SET BHLERR="CANNOT FIND V MED FOR DELETE"
SET BHLEDATA="V MED = "_BHLXKEY
QUIT
+2 SET DIK="^AUPNVMED("
DO ^DIK
+3 KILL DIK,DA
+4 QUIT
+5 ;
E ;edit an existing v med
+1 SET DA=$ORDER(^AUPNVMED("AXK",BHLXKEY,0))
IF DA=""
SET BHLERR="CANNOT FIND V MED FOR EDIT"
SET BHLEDATA="V MED = "_BHLXKEY
QUIT
+2 SET APCDALVR("APCDVSIT")=$PIECE(^AUPNVMED(DA,0),U,3)
+3 SET APCDALVR("APCDPAT")=$PIECE(^AUPNVMED(DA,0),U,2)
+4 SET DIK="^AUPNVMED("
DO ^DIK
KILL DIK,DA
+5 DO EMED
+6 IF BHLERR'=""
QUIT
+7 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.14 (ADD)]"
+8 DO ^APCDALVR
+9 IF $DATA(APCDALVR("APCDAFLG"))
SET BHLERR="V MED FAILED ON EDIT"
QUIT
+10 QUIT
+11 ;
INIT ;
+1 ;check to be sure that all required pieces of data are present
+2 ;if not, set error and quit
+3 NEW X,Y
+4 KILL APCDALVR
+5 IF BHLBPS("MED")=""
SET BHLERR="MISSING MED INFO"
QUIT
+6 SET BHLACT=$PIECE(BHLBPS("MED"),BHLFS,6)
+7 IF "^A^E^D^"'[(U_BHLACT_U)
SET BHLERR="INVALID ACTION"
SET BHLEDATA="ACTION = "_BHLACT
QUIT
+8 SET BHLXKEY=$PIECE(BHLBPS("MED"),BHLFS,5)
+9 IF BHLXKEY=""
SET BHLERR="MISSING EXTERNAL KEY"
QUIT
+10 IF BHLACT="D"
QUIT
+11 IF BHLBPS("PAT DEMO")=""
SET BHLERR="MISSING PATIENT DEMOGRAPHICS"
QUIT
+12 IF BHLBPS("VISIT")=""
SET BHLERR="MISSING VISIT INFO"
QUIT
+13 SET Y="NAME^DOB^SEX^SSN^CHART^FACILITY"
+14 FOR X=1,2,3,5,6
IF $PIECE(BHLBPS("PAT DEMO"),BHLFS,X)=""
SET BHLERR=BHLERR_","_$PIECE(Y,U,X)
+15 SET Y="VISIT DATE^SVC CAT^FACILITY"
+16 FOR X=1:1:3
IF $PIECE(BHLBPS("VISIT"),BHLFS,X)=""
SET BHLERR=BHLERR_","_$PIECE(Y,U,X)
+17 SET Y="RX NUMBER^QTY^DAYS PRESCRIBED^DISP DATE^EXTKEY^ACTION^REF^NDC^DRUG^UNITS^SIG^PROVIDER DEA#^PROVIDER NAME^RPH CODE^RPH NAME"
+18 FOR X=2,3,7,8,10,13,14
IF $PIECE(BHLBPS("MED"),BHLFS,X)=""
SET BHLERR=BHLERR_","_$PIECE(Y,U,X)
+19 IF $PIECE(BHLBPS("MED"),BHLFS,11)=""
IF $PIECE(BHLBPS("MED"),BHLFS,12)=""
SET BHLERR=BHLERR_","_$PIECE(Y,U,11)_","_$PIECE(Y,U,12)
+20 IF BHLERR'=""
SET BHLERR="MISSING DATA: "_$EXTRACT(BHLERR,2,$LENGTH(BHLERR))
+21 QUIT
+22 ;
EDIT ;edit all passed data, check against input tx
+1 ;edit record info against input transform
+2 DO GETPAT
+3 IF BHLERR'=""
QUIT
+4 ;edit visit information and set array
DO EVISIT
+5 ;edit v med and set up APCDALVR array
DO EMED
+6 QUIT
+7 ;
EMED ;
+1 NEW X,Y
+2 SET X=$PIECE(BHLBPS("MED"),BHLFS,8)
SET DIC(0)=""
SET DIC="^PSDRUG("
DO ^DIC
KILL DIC,DA,DR
+3 IF Y=-1
SET BHLBMSG="DRUG ENTRY COULD NOT BE FOUND BY NAME"
DO BULLETIN
SET X="OUTSIDE DRUG"
SET DIC="^PSDRUG("
SET DIC(0)="M"
DO ^DIC
IF Y=-1
SET BHLERR="OUTSIDE DRUG ENTRY NOT IN DRUG TABLE"
QUIT
+4 SET APCDALVR("APCDTRX")="`"_+Y
+5 IF $PIECE(Y,U,2)="OUTSIDE DRUG"
SET APCDALVR("APCDTNTD")=$PIECE(BHLBPS("MED"),BHLFS,8)
+6 ; check provider, quit if error
+7 ;
+8 DO PROV
IF BHLERR'=""
QUIT
+9 ;
+10 ;check sig
+11 ;
+12 KILL DIC
+13 SET X=$EXTRACT($PIECE(BHLBPS("MED"),BHLFS,10),1,145)
+14 KILL BHLBPSR
DO CHK^DIE(9000010.14,.05,"E",X,.BHLBPSR)
+15 IF BHLBPSR="^"
SET BHLERR="SIG FAILED INPUT TRANSFORM"
SET BHLEDATA="SIG = "_X
QUIT
+16 SET APCDALVR("APCDTSIG")=BHLBPSR
+17 SET BHLFILE=9000010.14
FOR BHLJ=2:1:5
IF BHLERR'=""
QUIT
SET BHLF=$PIECE("^.06^.07^1201^1209",U,BHLJ)
SET X=$PIECE(BHLBPS("MED"),BHLFS,BHLJ)
IF X'=""
KILL BHLBPSR
DO CHK^DIE(9000010.14,BHLF,"E",X,.BHLBPSR)
Begin DoDot:1
+18 IF BHLBPSR="^"
SET BHLERR="FIELD "_BHLF_" FAILED INPUT TRANSFORM IN V MED"
SET BHLEDATA=X
QUIT
+19 QUIT
End DoDot:1
+20 IF BHLERR'=""
QUIT
+21 SET APCDALVR("APCDTQTY")=$PIECE(BHLBPS("MED"),BHLFS,2)
+22 SET APCDALVR("APCDTDAY")=$PIECE(BHLBPS("MED"),BHLFS,3)
+23 SET APCDALVR("APCDTCDT")=$PIECE(BHLBPS("MED"),BHLFS,4)
+24 SET APCDALVR("APCDTEXK")=$PIECE(BHLBPS("MED"),BHLFS,5)
+25 QUIT
+26 ;
PROV ; Verify provider name/number
+1 ;
+2 NEW BHL200,VKPRVDEA,PCPRVDEA,VKPRVNAM,PRVIEN,DIC,X,Y
+3 ; pharmacy provider DEA #
SET VKPRVDEA=$PIECE(BHLBPS("MED"),BHLFS,11)
+4 ; pharmacy provider name
SET VKPRVNAM=$PIECE(BHLBPS("MED"),BHLFS,12)
+5 ; new person file flag
SET BHL200=$PIECE($GET(^AUTTSITE(1,0)),U,22)
+6 ;
+7 SET DIC=$SELECT(BHL200:"^VA(200,",1:"^DIC(6,")
SET DIC(0)="MOZ"
+8 SET X=VKPRVNAM
DO ^DIC
+9 IF Y=-1
SET X=VKPRVDEA
DO ^DIC
+10 IF Y=-1
SET BHLERR="PROVIDER FROM RX SYSTEM FAILED EDIT"
QUIT
+11 SET PRVIEN=$PIECE(Y,U,1)
SET PCPRVNAM=Y(0,0)
SET PCPRVDEA=$SELECT(BHL200:$PIECE($GET(^VA(200,PRVIEN,"PS")),U,2),1:$PIECE(Y(0),U,3))
+12 SET APCDALVR("APCDTPRV")="`"_+PRVIEN
+13 IF VKPRVDEA=""
SET BHLBMSG="PROVIDER DEA# NOT PROVIDED BY RX SYSTEM"
DO BULLETIN
QUIT
+14 IF PCPRVDEA=""
SET BHLBMSG="PROVIDER DEA# NOT FOUND IN PCC DATABASE"
DO BULLETIN
QUIT
+15 IF PCPRVDEA'=VKPRVDEA
SET BHLERR="PROVIDER DEA# MISMATCH"
QUIT
+16 IF VKPRVNAM=""
SET BHLBMSG="PROVIDER NAME NOT PROVIDED BY RX SYSTEM"
DO BULLETIN
QUIT
+17 IF '$$MATCH(VKPRVNAM,PCPRVNAM)
SET BHLBMSG="PROVIDER NAME MISMATCH"
DO BULLETIN
QUIT
+18 QUIT
+19 ;
EVISIT ;
+1 ;edit passed date,facility and set APCDALVR array
+2 SET Y=$PIECE(BHLBPS("VISIT"),BHLFS,1)
IF $PIECE(Y,".",2)=""
SET Y=Y_"@12:00"
+3 DO CHK^DIE(9000010,.01,"E",Y,.BHLBPSR)
+4 IF BHLBPSR="^"
SET BHLERR="VISIT DATE FAILED INPUT TRANSFORM"
SET BHLEDATA="VISIT DATE = "_Y
QUIT
+5 SET APCDALVR("APCDDATE")=BHLBPSR
+6 SET Y=$PIECE(BHLBPS("VISIT"),BHLFS,3)
SET Y=$ORDER(^AUTTLOC("C",Y,0))
+7 IF 'Y
SET BHLERR="COULD NOT LOOK UP LOCATION OF ENCOUNTER"
SET BHLEDATA="LOCATION = "_Y
QUIT
+8 SET APCDALVR("APCDLOC")=Y
+9 SET APCDALVR("APCDTYPE")=$SELECT($PIECE($GET(^APCCCTRL(Y,0)),U,4)'="":$PIECE(^APCCCTRL(Y,0),U,4),$PIECE($GET(^APCCCTRL(DUZ(2),0)),U,4)'="":$PIECE(^APCCCTRL(DUZ(2),0),U,4),1:"I")
+10 SET APCDALVR("APCDCAT")=$PIECE(BHLBPS("VISIT"),BHLFS,2)
DO CHK^DIE(9000010,.07,"E",APCDALVR("APCDCAT"),.BHLBPSR)
IF BHLBPSR="^"
SET BHLERR="SERVICE CATEGORY FAILED INPUT TRANSFORM"
SET BHLEDATA="SERVICE CATEGORY = "_APCDALVR("APCDCAT")
QUIT
+11 QUIT
+12 ;
GETPAT ;
+1 ;get patient IEN if possible
+2 ;if fails send bulletin
+3 ;if sex,ssn,dob don't match fail
+4 ;if name not exact, send warning bulletin
+5 NEW C,F,X,Y,PATDOB,PATSEX,PATSSN
+6 SET F=$PIECE(BHLBPS("PAT DEMO"),BHLFS,6)
+7 SET F=$ORDER(^AUTTLOC("C",F,0))
+8 IF 'F
SET BHLERR="FACILITY FOR HRN LOOKUP FAILED"
SET BHLEDATA="FACILITY = "_F
QUIT
+9 SET C=$PIECE(BHLBPS("PAT DEMO"),BHLFS,5)
SET BHLSEX=$PIECE(BHLBPS("PAT DEMO"),BHLFS,3)
SET BHLDOB=$PIECE(BHLBPS("PAT DEMO"),BHLFS,2)
SET BHLSSN=$PIECE(BHLBPS("PAT DEMO"),BHLFS,4)
+10 KILL DIC,DA,DR,DD,D0,DO
SET BHLDUZ2=DUZ(2)
SET DUZ(2)=F
SET X=C
SET DIC="^AUPNPAT("
SET DIC(0)="M"
DO ^DIC
+11 SET DUZ(2)=BHLDUZ2
KILL BHLDUZ2
+12 IF Y=-1
SET BHLERR="CHART NUMBER LOOKUP FAILED, CAN'T FIND PATIENT"
SET BHLEDATA="CHART NUMBER = "_X
QUIT
+13 SET IEN=$PIECE(Y,U,1)
+14 SET PATDOB=$PIECE(^DPT(IEN,0),U,3)
+15 IF BHLDOB'=PATDOB
SET BHLERR="DOB OF PATIENT DOES NOT MATCH"
SET BHLEDATA="PHARMACY DOB = "_BHLDOB_", PCC DOB = "_PATDOB
QUIT
+16 SET PATSEX=$PIECE(^DPT(IEN,0),U,2)
+17 IF BHLSEX'=""
IF PATSEX'=""
IF BHLSEX'=PATSEX
SET BHLERR="SEX OF PATIENT DOES NOT MATCH"
SET BHLEDATA="PHARMACY SEX = "_BHLSEX_", PCC SEX = "_PATSEX
QUIT
+18 SET PATSSN=$PIECE(^DPT(IEN,0),U,9)
+19 IF BHLSSN'=""
IF PATSSN'=""
IF BHLSSN'=PATSSN
SET BHLERR="SSN DOES NOT MATCH"
SET BHLEDATA="PHARMACY SSN = "_BHLSSN_", PCC SSN = "_PATSSN
QUIT
+20 IF '$$MATCH($PIECE(BHLBPS("PAT DEMO"),BHLFS,1),$PIECE(^DPT(IEN,0),U,1))
SET BHLBMSG="PAT NAME FROM PHARMACY SYSTEM DOES NOT MATCH PAT REG"
DO BULLETIN
+21 SET APCDALVR("APCDPAT")=IEN
+22 QUIT
+23 ;
MATCH(STR1,STR2) ; match up strings
+1 ;
+2 NEW MIN
+3 SET MIN=$SELECT($LENGTH(STR1)<$LENGTH(STR2):$LENGTH(STR1),1:$LENGTH(STR2))
+4 IF MIN<6
QUIT (STR1=STR2)
+5 QUIT ($EXTRACT(STR1,1,MIN)=$EXTRACT(STR2,1,MIN))
+6 ;
BULLETIN ;
+1 ; add error message to bulletin - bulletin will be sent later
+2 SET BHLBIDX=BHLBIDX+1
+3 SET XMB(BHLBIDX)=BHLBMSG
+4 QUIT
+5 ;
SENDBULL ;
+1 ; if debug mode, list bulletin errors on screen and quit
+2 IF $GET(BHLDBUG)
Begin DoDot:1
+3 WRITE !,"Warning Bulletin:"
+4 IF BHLBIDX=BHLEIDX
WRITE !,?3,"none"
QUIT
+5 NEW I
FOR I=8:1:BHLBIDX
WRITE !,?3,XMB(I)
End DoDot:1
KILL XMB
QUIT
+6 ;
+7 ; quit if nothing to send
+8 IF BHLBIDX=BHLEIDX
QUIT
+9 NEW %X,%Y,X,XMDT,XMDUZ,Y1
+10 ; bulletin name
+11 SET XMB="BHLBPS RX-PCC LINK DATA ERROR"
+12 ; PCC patient name
+13 SET XMB(1)=$SELECT($DATA(IEN):$PIECE(^DPT(IEN,0),U,1),1:"")
+14 ; pharmacy patient name
+15 SET XMB(2)=$PIECE(BHLBPS("PAT DEMO"),BHLFS,1)
+16 ; patient chart number
+17 SET XMB(3)=$PIECE(BHLBPS("PAT DEMO"),BHLFS,5)
+18 ; drug name
+19 SET XMB(4)=$PIECE(BHLBPS("MED"),BHLFS,8)
+20 ; dispense date
+21 SET Y=$PIECE(BHLBPS("MED"),BHLFS,4)
XECUTE ^DD("DD")
SET XMB(5)=Y
+22 ; pharmacy provider - name and DEA #
+23 SET XMB(6)=$PIECE(BHLBPS("MED"),BHLFS,12)_" "_$PIECE(BHLBPS("MED"),BHLFS,11)
+24 ; PCC provider name
+25 SET XMB(7)=$GET(PCPRVNAM)
+26 ; null out any unused parameters
+27 FOR BHLBIDX=BHLBIDX+1:1:BHLMIDX
SET XMB(BHLBIDX)=""
+28 SET XMDUZ=.5
+29 DO ^XMB
+30 KILL XMB
+31 QUIT
+32 ;
LOGAPCD ; Log APCDALVR array if debugging
+1 ;
+2 IF '$GET(BHLDBUG)
QUIT
+3 KILL ^TMP("BHLBPS",$JOB)
+4 NEW I
+5 SET I=""
FOR
SET I=$ORDER(APCDALVR(I))
IF I=""
QUIT
SET ^TMP("BHLBPS",$JOB,"APCDALVR",I)=APCDALVR(I)
+6 QUIT
