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

BTIUPCC2.m

Go to the documentation of this file.
  1. BTIUPCC2 ;IHS/CIA/MGH - TIU Object Support ;30-Jul-2010 08:33;MGH
  1. ;;1.0;TEXT INTEGRATION UTILITIES;**1003,1004,1005,1006**;NOV 04,2004
  1. ;New routine for objects added for TIU use
  1. ;Patch 1004 fixed logic for medications with different doses
  1. ;Patch 1005 added last dispensed date
  1. ;Patch 1005 fixed a problem with the med lookup
  1. ;Patch 1006 added a counter for the number of meds to return and added meds on hold
  1. PRIMPROV() ;Return primary provider name for visit from V Provider file
  1. N VSIT,PRVNAME,PIEN
  1. S PRVNAME="Unknown"
  1. S VSIT=$P($$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID","","CONTEXT.ENCOUNTER"),";",4)
  1. Q:'VSIT "Invalid visit"
  1. S PIEN=0
  1. F S PIEN=$O(^AUPNVPRV("AD",VSIT,PIEN)) Q:'PIEN D Q:PRVNAME'="Unknown"
  1. .I $P(^AUPNVPRV(PIEN,0),U,4)="P" D
  1. ..S PRVNAME=$P(^VA(200,+^AUPNVPRV(PIEN,0),0),U,1)
  1. Q PRVNAME
  1. ;
  1. ALLPROV(TARGET) ;Return all provider's names for visit from V Provider File
  1. N VSIT,CNT,PIEN
  1. K @TARGET
  1. S VSIT=$P($$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID","","CONTEXT.ENCOUNTER"),";",4)
  1. I 'VSIT D
  1. .S @TARGET@(1,0)="Visit undefined"
  1. E D
  1. .S CNT=0
  1. .S PIEN=0
  1. .F S PIEN=$O(^AUPNVPRV("AD",VSIT,PIEN)) Q:'PIEN D
  1. ..S CNT=CNT+1
  1. ..S @TARGET@(CNT,0)=$P(^VA(200,+^AUPNVPRV(PIEN,0),0),U,1)
  1. .I CNT=0 S @TARGET@(1,0)="No provider for visit"
  1. Q "~@"_$NA(@TARGET)
  1. ;
  1. LASTMED(DFN,BTIUMED,TARGET,VDC,CNT) ;Return Last Rx for drug or class selected.
  1. ;VDC is a flag, if 1 use VA drug class, if 0 or null use drug name
  1. ;BTIUMED is either drug name or VA drug class depending on VDC.
  1. ;does not have to be exact match with .01 field of file. Uses all lookup X-ref's on file
  1. ;For example a look up on aspirin will return all dosage forms for that drug.
  1. ;TARGET is the name of the array to store the results in
  1. N BTIUDRG,BTIUERR,FILE,INDX,DA,DRUG,SIG,RXIEN,IEN,IENS,INVDATE,N,I,EVENT,ARRAY
  1. N CHRONIC,COUNTER,DRUGIEN,EXDATE,LDATE,LINE,REASON,STATUS,X1,X2,X,CANDATE
  1. K @TARGET
  1. I '$D(CNT) S CNT=1
  1. S FILE=$S($G(VDC):50.605,1:50)
  1. I FILE=50 D FIND^DIC(FILE,"",".01;@","M",BTIUMED,"","","","","BTIUDRG","BTIUERR")
  1. I FILE=50.605 D
  1. .S BTIUDRG("DILIST",2,1)=$$FIND1^DIC(FILE,"","M",BTIUMED,"","","BTIUERR")
  1. .S $P(BTIUDRG("DILIST",0),U)=1
  1. I $D(BTIUERR("DIERR")) D
  1. .;Process the error
  1. .I $D(BTIUERR("DIERR","E",202)) D
  1. ..S @TARGET@(1,0)="Missing or invalid drug "_$S($G(VDC):"class",1:"name")
  1. .E S @TARGET@(1,0)=$G(BTIUERR("DIERR",1,"TEXT",1))
  1. E D
  1. .S INDX=0
  1. .F S INDX=$O(BTIUDRG("DILIST",2,INDX)) Q:'INDX D
  1. ..I FILE=50.605 D ;Get the list of drug ien's corresponding to the drug classes
  1. ...S DA=0
  1. ...F S DA=$O(^PSDRUG("VAC",BTIUDRG("DILIST",2,INDX),DA)) Q:'DA D
  1. ....S BTIUDRG(DA)=""
  1. ..E I FILE=50 D ;Just copy the drug ien's
  1. ...S BTIUDRG(BTIUDRG("DILIST",2,INDX))=""
  1. .I $G(VDC)=1 D
  1. ..S N="" S N=$O(^PS(50.605,"B",BTIUMED,N)) Q:N="" D
  1. ...S BTIUMED=N
  1. .S @TARGET@(1,0)="No Rx found for: "_BTIUMED
  1. .I $P(BTIUDRG("DILIST",0),U)=0 Q
  1. .S DRUG=""
  1. .S INVDATE=0
  1. .F S INVDATE=$O(^AUPNVMED("AA",DFN,INVDATE)) Q:'INVDATE D ;Q:DRUG]""
  1. ..S DA=0
  1. ..F S DA=$O(^AUPNVMED("AA",DFN,INVDATE,DA)) Q:'DA D ;Q:DRUG]""
  1. ...S DRUGIEN=+^AUPNVMED(DA,0)
  1. ...S IEN=0
  1. ...F S IEN=$O(BTIUDRG(IEN)) Q:'IEN D ;Q:DRUG]""
  1. ....I IEN=DRUGIEN D
  1. .....S DRUG=$P(^PSDRUG(IEN,0),U)
  1. .....S EVENT=$$GET1^DIQ(9000010.14,DA_",",1201,"","","BTIUERR")
  1. .....S ARRAY(INVDATE,DA)=DRUG_"^"_EVENT
  1. .;after you get all the drugs into the array take number requested
  1. .S COUNTER=1,LINE=0
  1. .S I="" F S I=$O(ARRAY(I)) Q:I=""!(COUNTER>CNT) D
  1. ..S DA="" F S DA=$O(ARRAY(I,DA)) Q:DA="" D
  1. ...S COUNTER=COUNTER+1
  1. ...S DRUG=$P(ARRAY(I,DA),U,1),EVENT=$P(ARRAY(I,DA),U,2)
  1. ...S SIG=$P(^AUPNVMED(DA,0),U,5)
  1. ...S RXIEN=$O(^PSRX("APCC",DA,""))
  1. ...I 'RXIEN D Q
  1. ....S LINE=LINE+1
  1. ....S @TARGET@(LINE,0)="Last Rx for: "_DRUG
  1. ....S LINE=LINE+1
  1. ....S @TARGET@(LINE,0)="Sig: "_SIG
  1. ....S LINE=LINE+1
  1. ....S @TARGET@(LINE,0)="Event date: "_EVENT
  1. ...S IENS=RXIEN_","
  1. ...K BTIUERR,BTIUDAT
  1. ...D GETS^DIQ(52,IENS,"1;22;100;101;9999999.02","","BTIUDAT","BTIUERR")
  1. ...I $D(BTIUERR("DIERR")) D Q
  1. ....;Process the error
  1. ....S LINE=LINE+1
  1. ....S @TARGET@(LINE,0)=$G(BTIUERR("DIERR",1,"TEXT",1))
  1. ...S STATUS=BTIUDAT(52,IENS,100)
  1. ...S CHRONIC=BTIUDAT(52,IENS,9999999.02)
  1. ...I STATUS="EXPIRED" D Q:LDATE>EXDATE
  1. ....S EXDATE=$$GET1^DIQ(52,IENS,26,"I")
  1. ....I CHRONIC S X1=DT,X2=-120 D C^%DTC S LDATE=X
  1. ....E S X1=DT,X2=-14 D C^%DTC S LDATE=X
  1. ...I STATUS="DISCONTINUED" D Q:LDATE>CANDATE
  1. ....S CANDATE=$$GET1^DIQ(52,IENS,26.1,"I")
  1. ....S X1=DT,X2=-30 D C^%DTC S LDATE=X
  1. ...S LINE=LINE+1
  1. ...S @TARGET@(LINE,0)="Last Rx for: "_DRUG
  1. ...S LINE=LINE+1
  1. ...S @TARGET@(LINE,0)="Sig: "_SIG
  1. ...;issue date #1, 0;13
  1. ...;fill date #22, 2;2
  1. ...;status #100, STA;1
  1. ...S LINE=LINE+1
  1. ...S @TARGET@(LINE,0)="Issue date: "_BTIUDAT(52,IENS,1)
  1. ...S LINE=LINE+1
  1. ...S @TARGET@(LINE,0)="Fill date: "_BTIUDAT(52,IENS,22)
  1. ...S LINE=LINE+1
  1. ...S @TARGET@(LINE,0)="Last Dispensed date: "_BTIUDAT(52,IENS,101)
  1. ...S LINE=LINE+1
  1. ...S @TARGET@(LINE,0)="Status: "_BTIUDAT(52,IENS,100)
  1. ...I STATUS="HOLD" D
  1. ....S REASON=$$GET1^DIQ(52,IENS,99,"E")
  1. ....S LINE=LINE+1 S @TARGET@(LINE,0)="Reason for hold: "_REASON
  1. ...S LINE=LINE+1 S @TARGET@(LINE,0)=" "
  1. Q "~@"_$NA(@TARGET)
  1. ;
  1. FNAME(DFN) ;Patient First name
  1. N FULNAME,FIRSTN
  1. S FULNAME=$$NAME^TIULO(DFN)
  1. S FIRSTN=$P($P(FULNAME,",",2)," ",1)
  1. I FIRSTN="" S FIRSTN="UNKNOWN"
  1. Q FIRSTN
  1. LNAME(DFN) ;Patient Last Name
  1. N FULNAME,LASTN
  1. S FULNAME=$$NAME^TIULO(DFN)
  1. S LASTN=$P(FULNAME,",",1)
  1. Q LASTN