- 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