Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BHLBPS1

BHLBPS1.m

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