BTIUPCC2 ;IHS/CIA/MGH - TIU Object Support ;30-Jul-2010 08:33;MGH
;;1.0;TEXT INTEGRATION UTILITIES;**1003,1004,1005,1006**;NOV 04,2004
;New routine for objects added for TIU use
;Patch 1004 fixed logic for medications with different doses
;Patch 1005 added last dispensed date
;Patch 1005 fixed a problem with the med lookup
;Patch 1006 added a counter for the number of meds to return and added meds on hold
PRIMPROV() ;Return primary provider name for visit from V Provider file
N VSIT,PRVNAME,PIEN
S PRVNAME="Unknown"
S VSIT=$P($$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID","","CONTEXT.ENCOUNTER"),";",4)
Q:'VSIT "Invalid visit"
S PIEN=0
F S PIEN=$O(^AUPNVPRV("AD",VSIT,PIEN)) Q:'PIEN D Q:PRVNAME'="Unknown"
.I $P(^AUPNVPRV(PIEN,0),U,4)="P" D
..S PRVNAME=$P(^VA(200,+^AUPNVPRV(PIEN,0),0),U,1)
Q PRVNAME
;
ALLPROV(TARGET) ;Return all provider's names for visit from V Provider File
N VSIT,CNT,PIEN
K @TARGET
S VSIT=$P($$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID","","CONTEXT.ENCOUNTER"),";",4)
I 'VSIT D
.S @TARGET@(1,0)="Visit undefined"
E D
.S CNT=0
.S PIEN=0
.F S PIEN=$O(^AUPNVPRV("AD",VSIT,PIEN)) Q:'PIEN D
..S CNT=CNT+1
..S @TARGET@(CNT,0)=$P(^VA(200,+^AUPNVPRV(PIEN,0),0),U,1)
.I CNT=0 S @TARGET@(1,0)="No provider for visit"
Q "~@"_$NA(@TARGET)
;
LASTMED(DFN,BTIUMED,TARGET,VDC,CNT) ;Return Last Rx for drug or class selected.
;VDC is a flag, if 1 use VA drug class, if 0 or null use drug name
;BTIUMED is either drug name or VA drug class depending on VDC.
;does not have to be exact match with .01 field of file. Uses all lookup X-ref's on file
;For example a look up on aspirin will return all dosage forms for that drug.
;TARGET is the name of the array to store the results in
N BTIUDRG,BTIUERR,FILE,INDX,DA,DRUG,SIG,RXIEN,IEN,IENS,INVDATE,N,I,EVENT,ARRAY
N CHRONIC,COUNTER,DRUGIEN,EXDATE,LDATE,LINE,REASON,STATUS,X1,X2,X,CANDATE
K @TARGET
I '$D(CNT) S CNT=1
S FILE=$S($G(VDC):50.605,1:50)
I FILE=50 D FIND^DIC(FILE,"",".01;@","M",BTIUMED,"","","","","BTIUDRG","BTIUERR")
I FILE=50.605 D
.S BTIUDRG("DILIST",2,1)=$$FIND1^DIC(FILE,"","M",BTIUMED,"","","BTIUERR")
.S $P(BTIUDRG("DILIST",0),U)=1
I $D(BTIUERR("DIERR")) D
.;Process the error
.I $D(BTIUERR("DIERR","E",202)) D
..S @TARGET@(1,0)="Missing or invalid drug "_$S($G(VDC):"class",1:"name")
.E S @TARGET@(1,0)=$G(BTIUERR("DIERR",1,"TEXT",1))
E D
.S INDX=0
.F S INDX=$O(BTIUDRG("DILIST",2,INDX)) Q:'INDX D
..I FILE=50.605 D ;Get the list of drug ien's corresponding to the drug classes
...S DA=0
...F S DA=$O(^PSDRUG("VAC",BTIUDRG("DILIST",2,INDX),DA)) Q:'DA D
....S BTIUDRG(DA)=""
..E I FILE=50 D ;Just copy the drug ien's
...S BTIUDRG(BTIUDRG("DILIST",2,INDX))=""
.I $G(VDC)=1 D
..S N="" S N=$O(^PS(50.605,"B",BTIUMED,N)) Q:N="" D
...S BTIUMED=N
.S @TARGET@(1,0)="No Rx found for: "_BTIUMED
.I $P(BTIUDRG("DILIST",0),U)=0 Q
.S DRUG=""
.S INVDATE=0
.F S INVDATE=$O(^AUPNVMED("AA",DFN,INVDATE)) Q:'INVDATE D ;Q:DRUG]""
..S DA=0
..F S DA=$O(^AUPNVMED("AA",DFN,INVDATE,DA)) Q:'DA D ;Q:DRUG]""
...S DRUGIEN=+^AUPNVMED(DA,0)
...S IEN=0
...F S IEN=$O(BTIUDRG(IEN)) Q:'IEN D ;Q:DRUG]""
....I IEN=DRUGIEN D
.....S DRUG=$P(^PSDRUG(IEN,0),U)
.....S EVENT=$$GET1^DIQ(9000010.14,DA_",",1201,"","","BTIUERR")
.....S ARRAY(INVDATE,DA)=DRUG_"^"_EVENT
.;after you get all the drugs into the array take number requested
.S COUNTER=1,LINE=0
.S I="" F S I=$O(ARRAY(I)) Q:I=""!(COUNTER>CNT) D
..S DA="" F S DA=$O(ARRAY(I,DA)) Q:DA="" D
...S COUNTER=COUNTER+1
...S DRUG=$P(ARRAY(I,DA),U,1),EVENT=$P(ARRAY(I,DA),U,2)
...S SIG=$P(^AUPNVMED(DA,0),U,5)
...S RXIEN=$O(^PSRX("APCC",DA,""))
...I 'RXIEN D Q
....S LINE=LINE+1
....S @TARGET@(LINE,0)="Last Rx for: "_DRUG
....S LINE=LINE+1
....S @TARGET@(LINE,0)="Sig: "_SIG
....S LINE=LINE+1
....S @TARGET@(LINE,0)="Event date: "_EVENT
...S IENS=RXIEN_","
...K BTIUERR,BTIUDAT
...D GETS^DIQ(52,IENS,"1;22;100;101;9999999.02","","BTIUDAT","BTIUERR")
...I $D(BTIUERR("DIERR")) D Q
....;Process the error
....S LINE=LINE+1
....S @TARGET@(LINE,0)=$G(BTIUERR("DIERR",1,"TEXT",1))
...S STATUS=BTIUDAT(52,IENS,100)
...S CHRONIC=BTIUDAT(52,IENS,9999999.02)
...I STATUS="EXPIRED" D Q:LDATE>EXDATE
....S EXDATE=$$GET1^DIQ(52,IENS,26,"I")
....I CHRONIC S X1=DT,X2=-120 D C^%DTC S LDATE=X
....E S X1=DT,X2=-14 D C^%DTC S LDATE=X
...I STATUS="DISCONTINUED" D Q:LDATE>CANDATE
....S CANDATE=$$GET1^DIQ(52,IENS,26.1,"I")
....S X1=DT,X2=-30 D C^%DTC S LDATE=X
...S LINE=LINE+1
...S @TARGET@(LINE,0)="Last Rx for: "_DRUG
...S LINE=LINE+1
...S @TARGET@(LINE,0)="Sig: "_SIG
...;issue date #1, 0;13
...;fill date #22, 2;2
...;status #100, STA;1
...S LINE=LINE+1
...S @TARGET@(LINE,0)="Issue date: "_BTIUDAT(52,IENS,1)
...S LINE=LINE+1
...S @TARGET@(LINE,0)="Fill date: "_BTIUDAT(52,IENS,22)
...S LINE=LINE+1
...S @TARGET@(LINE,0)="Last Dispensed date: "_BTIUDAT(52,IENS,101)
...S LINE=LINE+1
...S @TARGET@(LINE,0)="Status: "_BTIUDAT(52,IENS,100)
...I STATUS="HOLD" D
....S REASON=$$GET1^DIQ(52,IENS,99,"E")
....S LINE=LINE+1 S @TARGET@(LINE,0)="Reason for hold: "_REASON
...S LINE=LINE+1 S @TARGET@(LINE,0)=" "
Q "~@"_$NA(@TARGET)
;
FNAME(DFN) ;Patient First name
N FULNAME,FIRSTN
S FULNAME=$$NAME^TIULO(DFN)
S FIRSTN=$P($P(FULNAME,",",2)," ",1)
I FIRSTN="" S FIRSTN="UNKNOWN"
Q FIRSTN
LNAME(DFN) ;Patient Last Name
N FULNAME,LASTN
S FULNAME=$$NAME^TIULO(DFN)
S LASTN=$P(FULNAME,",",1)
Q LASTN
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
+2 ;New routine for objects added for TIU use
+3 ;Patch 1004 fixed logic for medications with different doses
+4 ;Patch 1005 added last dispensed date
+5 ;Patch 1005 fixed a problem with the med lookup
+6 ;Patch 1006 added a counter for the number of meds to return and added meds on hold
PRIMPROV() ;Return primary provider name for visit from V Provider file
+1 NEW VSIT,PRVNAME,PIEN
+2 SET PRVNAME="Unknown"
+3 SET VSIT=$PIECE($$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID","","CONTEXT.ENCOUNTER"),";",4)
+4 IF 'VSIT
QUIT "Invalid visit"
+5 SET PIEN=0
+6 FOR
SET PIEN=$ORDER(^AUPNVPRV("AD",VSIT,PIEN))
IF 'PIEN
QUIT
Begin DoDot:1
+7 IF $PIECE(^AUPNVPRV(PIEN,0),U,4)="P"
Begin DoDot:2
+8 SET PRVNAME=$PIECE(^VA(200,+^AUPNVPRV(PIEN,0),0),U,1)
End DoDot:2
End DoDot:1
IF PRVNAME'="Unknown"
QUIT
+9 QUIT PRVNAME
+10 ;
ALLPROV(TARGET) ;Return all provider's names for visit from V Provider File
+1 NEW VSIT,CNT,PIEN
+2 KILL @TARGET
+3 SET VSIT=$PIECE($$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID","","CONTEXT.ENCOUNTER"),";",4)
+4 IF 'VSIT
Begin DoDot:1
+5 SET @TARGET@(1,0)="Visit undefined"
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 SET CNT=0
+8 SET PIEN=0
+9 FOR
SET PIEN=$ORDER(^AUPNVPRV("AD",VSIT,PIEN))
IF 'PIEN
QUIT
Begin DoDot:2
+10 SET CNT=CNT+1
+11 SET @TARGET@(CNT,0)=$PIECE(^VA(200,+^AUPNVPRV(PIEN,0),0),U,1)
End DoDot:2
+12 IF CNT=0
SET @TARGET@(1,0)="No provider for visit"
End DoDot:1
+13 QUIT "~@"_$NAME(@TARGET)
+14 ;
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
+2 ;BTIUMED is either drug name or VA drug class depending on VDC.
+3 ;does not have to be exact match with .01 field of file. Uses all lookup X-ref's on file
+4 ;For example a look up on aspirin will return all dosage forms for that drug.
+5 ;TARGET is the name of the array to store the results in
+6 NEW BTIUDRG,BTIUERR,FILE,INDX,DA,DRUG,SIG,RXIEN,IEN,IENS,INVDATE,N,I,EVENT,ARRAY
+7 NEW CHRONIC,COUNTER,DRUGIEN,EXDATE,LDATE,LINE,REASON,STATUS,X1,X2,X,CANDATE
+8 KILL @TARGET
+9 IF '$DATA(CNT)
SET CNT=1
+10 SET FILE=$SELECT($GET(VDC):50.605,1:50)
+11 IF FILE=50
DO FIND^DIC(FILE,"",".01;@","M",BTIUMED,"","","","","BTIUDRG","BTIUERR")
+12 IF FILE=50.605
Begin DoDot:1
+13 SET BTIUDRG("DILIST",2,1)=$$FIND1^DIC(FILE,"","M",BTIUMED,"","","BTIUERR")
+14 SET $PIECE(BTIUDRG("DILIST",0),U)=1
End DoDot:1
+15 IF $DATA(BTIUERR("DIERR"))
Begin DoDot:1
+16 ;Process the error
+17 IF $DATA(BTIUERR("DIERR","E",202))
Begin DoDot:2
+18 SET @TARGET@(1,0)="Missing or invalid drug "_$SELECT($GET(VDC):"class",1:"name")
End DoDot:2
+19 IF '$TEST
SET @TARGET@(1,0)=$GET(BTIUERR("DIERR",1,"TEXT",1))
End DoDot:1
+20 IF '$TEST
Begin DoDot:1
+21 SET INDX=0
+22 FOR
SET INDX=$ORDER(BTIUDRG("DILIST",2,INDX))
IF 'INDX
QUIT
Begin DoDot:2
+23 ;Get the list of drug ien's corresponding to the drug classes
IF FILE=50.605
Begin DoDot:3
+24 SET DA=0
+25 FOR
SET DA=$ORDER(^PSDRUG("VAC",BTIUDRG("DILIST",2,INDX),DA))
IF 'DA
QUIT
Begin DoDot:4
+26 SET BTIUDRG(DA)=""
End DoDot:4
End DoDot:3
+27 ;Just copy the drug ien's
IF '$TEST
IF FILE=50
Begin DoDot:3
+28 SET BTIUDRG(BTIUDRG("DILIST",2,INDX))=""
End DoDot:3
End DoDot:2
+29 IF $GET(VDC)=1
Begin DoDot:2
+30 SET N=""
SET N=$ORDER(^PS(50.605,"B",BTIUMED,N))
IF N=""
QUIT
Begin DoDot:3
+31 SET BTIUMED=N
End DoDot:3
End DoDot:2
+32 SET @TARGET@(1,0)="No Rx found for: "_BTIUMED
+33 IF $PIECE(BTIUDRG("DILIST",0),U)=0
QUIT
+34 SET DRUG=""
+35 SET INVDATE=0
+36 ;Q:DRUG]""
FOR
SET INVDATE=$ORDER(^AUPNVMED("AA",DFN,INVDATE))
IF 'INVDATE
QUIT
Begin DoDot:2
+37 SET DA=0
+38 ;Q:DRUG]""
FOR
SET DA=$ORDER(^AUPNVMED("AA",DFN,INVDATE,DA))
IF 'DA
QUIT
Begin DoDot:3
+39 SET DRUGIEN=+^AUPNVMED(DA,0)
+40 SET IEN=0
+41 ;Q:DRUG]""
FOR
SET IEN=$ORDER(BTIUDRG(IEN))
IF 'IEN
QUIT
Begin DoDot:4
+42 IF IEN=DRUGIEN
Begin DoDot:5
+43 SET DRUG=$PIECE(^PSDRUG(IEN,0),U)
+44 SET EVENT=$$GET1^DIQ(9000010.14,DA_",",1201,"","","BTIUERR")
+45 SET ARRAY(INVDATE,DA)=DRUG_"^"_EVENT
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+46 ;after you get all the drugs into the array take number requested
+47 SET COUNTER=1
SET LINE=0
+48 SET I=""
FOR
SET I=$ORDER(ARRAY(I))
IF I=""!(COUNTER>CNT)
QUIT
Begin DoDot:2
+49 SET DA=""
FOR
SET DA=$ORDER(ARRAY(I,DA))
IF DA=""
QUIT
Begin DoDot:3
+50 SET COUNTER=COUNTER+1
+51 SET DRUG=$PIECE(ARRAY(I,DA),U,1)
SET EVENT=$PIECE(ARRAY(I,DA),U,2)
+52 SET SIG=$PIECE(^AUPNVMED(DA,0),U,5)
+53 SET RXIEN=$ORDER(^PSRX("APCC",DA,""))
+54 IF 'RXIEN
Begin DoDot:4
+55 SET LINE=LINE+1
+56 SET @TARGET@(LINE,0)="Last Rx for: "_DRUG
+57 SET LINE=LINE+1
+58 SET @TARGET@(LINE,0)="Sig: "_SIG
+59 SET LINE=LINE+1
+60 SET @TARGET@(LINE,0)="Event date: "_EVENT
End DoDot:4
QUIT
+61 SET IENS=RXIEN_","
+62 KILL BTIUERR,BTIUDAT
+63 DO GETS^DIQ(52,IENS,"1;22;100;101;9999999.02","","BTIUDAT","BTIUERR")
+64 IF $DATA(BTIUERR("DIERR"))
Begin DoDot:4
+65 ;Process the error
+66 SET LINE=LINE+1
+67 SET @TARGET@(LINE,0)=$GET(BTIUERR("DIERR",1,"TEXT",1))
End DoDot:4
QUIT
+68 SET STATUS=BTIUDAT(52,IENS,100)
+69 SET CHRONIC=BTIUDAT(52,IENS,9999999.02)
+70 IF STATUS="EXPIRED"
Begin DoDot:4
+71 SET EXDATE=$$GET1^DIQ(52,IENS,26,"I")
+72 IF CHRONIC
SET X1=DT
SET X2=-120
DO C^%DTC
SET LDATE=X
+73 IF '$TEST
SET X1=DT
SET X2=-14
DO C^%DTC
SET LDATE=X
End DoDot:4
IF LDATE>EXDATE
QUIT
+74 IF STATUS="DISCONTINUED"
Begin DoDot:4
+75 SET CANDATE=$$GET1^DIQ(52,IENS,26.1,"I")
+76 SET X1=DT
SET X2=-30
DO C^%DTC
SET LDATE=X
End DoDot:4
IF LDATE>CANDATE
QUIT
+77 SET LINE=LINE+1
+78 SET @TARGET@(LINE,0)="Last Rx for: "_DRUG
+79 SET LINE=LINE+1
+80 SET @TARGET@(LINE,0)="Sig: "_SIG
+81 ;issue date #1, 0;13
+82 ;fill date #22, 2;2
+83 ;status #100, STA;1
+84 SET LINE=LINE+1
+85 SET @TARGET@(LINE,0)="Issue date: "_BTIUDAT(52,IENS,1)
+86 SET LINE=LINE+1
+87 SET @TARGET@(LINE,0)="Fill date: "_BTIUDAT(52,IENS,22)
+88 SET LINE=LINE+1
+89 SET @TARGET@(LINE,0)="Last Dispensed date: "_BTIUDAT(52,IENS,101)
+90 SET LINE=LINE+1
+91 SET @TARGET@(LINE,0)="Status: "_BTIUDAT(52,IENS,100)
+92 IF STATUS="HOLD"
Begin DoDot:4
+93 SET REASON=$$GET1^DIQ(52,IENS,99,"E")
+94 SET LINE=LINE+1
SET @TARGET@(LINE,0)="Reason for hold: "_REASON
End DoDot:4
+95 SET LINE=LINE+1
SET @TARGET@(LINE,0)=" "
End DoDot:3
End DoDot:2
End DoDot:1
+96 QUIT "~@"_$NAME(@TARGET)
+97 ;
FNAME(DFN) ;Patient First name
+1 NEW FULNAME,FIRSTN
+2 SET FULNAME=$$NAME^TIULO(DFN)
+3 SET FIRSTN=$PIECE($PIECE(FULNAME,",",2)," ",1)
+4 IF FIRSTN=""
SET FIRSTN="UNKNOWN"
+5 QUIT FIRSTN
LNAME(DFN) ;Patient Last Name
+1 NEW FULNAME,LASTN
+2 SET FULNAME=$$NAME^TIULO(DFN)
+3 SET LASTN=$PIECE(FULNAME,",",1)
+4 QUIT LASTN
