- PSBZVSD ;IHS/MSC/MGH - BCMA RPCS ;24-Mar-2014 23:48;DU
- ;;3.0;BAR CODE MED ADMIN;**1017**;Mar 2004;Build 40
- ;Search virtual due list to see why the scanned in med was not found in it
- ;Search is first for VA Generic drug, then STRENGTH and then ROUTE
- ;Return message on what was not found
- ;Inp= TYPE ^ IEN -type is DD,SOL,ADD, or ID
- ; List= List of IENs on VDL for that same page
- ;Ret=-1^text ^header ^ .01 of IEN
- EN(DATA,DRGIEN,DFN,LIST) ;EP-
- S DATA(0)=1
- S DATA(1)="-1^Invalid Medication Lookup"
- Q:$G(DUZ("AG"))'="I"
- N DMATCH,SMATCH,RMATCH,DNAME,VANAME
- S RET="",(DMATCH,SMATCH,RMATCH)=0
- S DRGIEN=$$FIND1^DIC(50,"","AX",DRGIEN,"B^C") ;Allows lookup by Drug IEN or Synonym
- Q:'DRGIEN
- S DNAME=$$GET1^DIQ(50,DRGIEN,.01)
- S VANAME=$$GET1^DIQ(50,DRGIEN,20)
- D DISP(DRGIEN,VANAME,.LIST)
- Q
- DISP(DRG,VANAME,LIST) ;EP-
- N CDRG,NAME,IEN,GIEN,TYPE,IEN
- S CDRG="" F S CDRG=$O(LIST(CDRG)) Q:CDRG="" D
- .S IEN=$G(LIST(CDRG))
- .S TYPE=$P($G(LIST(CDRG)),U,1)
- .S IEN=$P($G(LIST(CDRG)),U,2)
- .Q:'+IEN
- .S GIEN=$S(TYPE="SOL":$$GET1^DIQ(52.7,IEN,1,"I"),TYPE="ADD":$$GET1^DIQ(52.6,IEN,1,"I"),TYPE="DD":IEN,1:"")
- .S NAME=$$GET1^DIQ(50,GIEN,20)
- .I NAME=VANAME S DMATCH=1 D ROUTE(DRG,GIEN)
- I DMATCH=0&(SMATCH=0)&(RMATCH=0) S DATA(1)="-1^Scanned Drug Not Found in Virtual Due List^Wrong Drug ^"_DNAME Q
- I DMATCH=1&(RMATCH=0)&(SMATCH=0) S DATA(1)="-1^Scanned Drug dose does not match route ordered^Wrong Route ^"_DNAME Q
- I DMATCH=1&(RMATCH=1)&(SMATCH=0) S DATA(1)="-1^Scanned Drug does not match dose ordered^Wrong Dose ^"_DNAME Q
- I DMATCH=1&(RMATCH=1)&(SMATCH=1) S DATA(1)="-1^Idential match is not found.Please use Unable to Scan option ^Not Identical ^"_DNAME
- Q
- STRENGTH(DRG,GIEN) ;EP -see if the strength matches
- N VASTR,DRSTR1
- S VASTR=$$GET1^DIQ(50,DRG,901)
- S DRSTR=$$GET1^DIQ(50,GIEN,901)
- I VASTR=""&(DRSTR="") D
- .S VASTR=$$GET1^DIQ(50,DRG,21,"I")
- .S DRSTR=$$GET1^DIQ(50,GIEN,21,"I")
- I VASTR=DRSTR S SMATCH=1
- Q
- ROUTE(DRG,GIEN) ;EP- See if the route matches
- N VAROU,DRROU,POI,POI2
- S POI=$$GET1^DIQ(50,DRG,2.1,"I")
- S POI2=$$GET1^DIQ(50,GIEN,2.1,"I")
- S VAROU=$$GET1^DIQ(50.7,POI,.06)
- S DRROU=$$GET1^DIQ(50.7,POI2,.06)
- I VAROU=DRROU S RMATCH=1 D STRENGTH(DRG,GIEN)
- Q
- ;For IV barcodes, check that the patient matches
- ;If pt matches then find the bag number in file 55
- ;If its there, compare it to items on the VDL
- ;Inp= CNT from calling program
- ; STRING= Scanned barcode
- ; TAB = BCMA tab (PBTAB,IVTAB)
- IVCHK(DATA,CNT,STRING,TAB,DFN) ;EP- Check for IV bag barcode match
- I STRING["V"!(STRING["W") D
- .I DFN'="" D
- ..I DFN=+STRING D CHKIV Q
- ..I DFN'=+STRING S DATA(CNT)="-1^Scanned drug does not match patient^Wrong Patient"
- E I STRING?.N D
- .D:$G(DFN) CHKDRG
- Q
- ;
- CHKDRG ;EP-
- N SLIST,ALIST,SOL,ADD,DD,ERR,CNT,IEN,ERRTXT,ERRTXT2,NAME
- S ERR=0,CNT=0
- K LIST
- S NAME=$$GET1^DIQ(50,STRING,.01)
- D GETLST(.SLIST,.ALIST)
- S INP=STRING
- S SOL=0 F S SOL=$O(SLIST(SOL)) Q:SOL="" D
- .S IEN=$G(SLIST(SOL))
- .I IEN'="" D
- ..S DD=$P($G(^PS(52.7,IEN,0)),U,2)
- ..S CNT=CNT+1
- ..S LIST(CNT)="DD^"_DD
- S ADD=0 F S ADD=$O(ALIST(ADD)) Q:ADD="" D
- .S IEN=$G(ALIST(ADD))
- .I IEN'="" D
- ..S DD=$P($G(^PS(52.6,IEN,0)),U,2)
- ..S CNT=CNT+1
- ..S LIST(CNT)="DD^"_DD
- D EN(.ERR,INP,DFN,.LIST)
- Q
- CHKIV ;EP- Find the item in pts list
- N IEN,BAG,DONE,LIST,ADDIEN,SOLIEN,SLIST,ALIST,RETURN,ERR
- S DONE=0,DATA="",ERR=0
- S IEN=0 F S IEN=$O(^PS(55,DFN,"IVBCMA",IEN)) Q:IEN=""!(DONE=1) D
- .S BAG=$P($G(^PS(55,DFN,"IVBCMA",IEN,0)),U,1)
- .I BAG=STRING D
- ..S DONE=1
- ..D GETLST(.SLIST,.ALIST)
- ..S SOL=0 F S SOL=$O(^PS(55,DFN,"IVBCMA",IEN,"SOL",SOL)) Q:SOL=""!(ERR=1) D
- ...S SOLIEN=$P($G(^PS(55,DFN,"IVBCMA",IEN,"SOL",SOL,0)),U,1)
- ...S INP="SOL^"_SOLIEN
- ...D EN(.RETURN,INP,DFN,.SLIST)
- ...I $D(RETURN(1)) S ERR=1,DATA(CNT)=RETURN(1)
- ..Q:ERR=1
- ..S ADD=0 F S ADD=$O(^PS(55,DFN,"IVBCMA",IEN,"AD",ADD)) Q:ADD=""!(ERR=1) D
- ...S ADDIEN=$P($G(^PS(55,DFN,"IVBCMA",IEN,"AD",ADD,0)),U,1)
- ...S INP="ADD^"_ADDIEN
- ...D EN(.RETURN,INP,DFN,.ALIST)
- ...I $D(RETURN(1)) S ERR=1,DATA(CNT)=RETURN(1)
- I DONE=0 S DATA(CNT)="-1^Drug Not Found in Virtual Due List^Wrong Drug"
- Q
- GETLST(SLIST,ALIST) ;EP- Get list of solutions and additives
- N SIEN,AIEN,RESULTS,NODE,CNT2
- S CNT2=1
- K ^TMP("PSB",$J)
- D RPC^PSBVDLTB(.RESULTS,DFN,TAB)
- S NUM=$G(@RESULTS@(0))
- F I=2:1:NUM D
- .S NODE=$G(@RESULTS@(I))
- .I $P(NODE,U,1)="SOL" S SLIST(CNT2)=$P(NODE,U,2)
- .I $P(NODE,U,1)="ADD" S ALIST(CNT2)=$P(NODE,U,2)
- .I $P(NODE,U,1)="END" S CNT2=CNT2+1
- Q
- PSBZVSD ;IHS/MSC/MGH - BCMA RPCS ;24-Mar-2014 23:48;DU
- +1 ;;3.0;BAR CODE MED ADMIN;**1017**;Mar 2004;Build 40
- +2 ;Search virtual due list to see why the scanned in med was not found in it
- +3 ;Search is first for VA Generic drug, then STRENGTH and then ROUTE
- +4 ;Return message on what was not found
- +5 ;Inp= TYPE ^ IEN -type is DD,SOL,ADD, or ID
- +6 ; List= List of IENs on VDL for that same page
- +7 ;Ret=-1^text ^header ^ .01 of IEN
- EN(DATA,DRGIEN,DFN,LIST) ;EP-
- +1 SET DATA(0)=1
- +2 SET DATA(1)="-1^Invalid Medication Lookup"
- +3 IF $GET(DUZ("AG"))'="I"
- QUIT
- +4 NEW DMATCH,SMATCH,RMATCH,DNAME,VANAME
- +5 SET RET=""
- SET (DMATCH,SMATCH,RMATCH)=0
- +6 ;Allows lookup by Drug IEN or Synonym
- SET DRGIEN=$$FIND1^DIC(50,"","AX",DRGIEN,"B^C")
- +7 IF 'DRGIEN
- QUIT
- +8 SET DNAME=$$GET1^DIQ(50,DRGIEN,.01)
- +9 SET VANAME=$$GET1^DIQ(50,DRGIEN,20)
- +10 DO DISP(DRGIEN,VANAME,.LIST)
- +11 QUIT
- DISP(DRG,VANAME,LIST) ;EP-
- +1 NEW CDRG,NAME,IEN,GIEN,TYPE,IEN
- +2 SET CDRG=""
- FOR
- SET CDRG=$ORDER(LIST(CDRG))
- IF CDRG=""
- QUIT
- Begin DoDot:1
- +3 SET IEN=$GET(LIST(CDRG))
- +4 SET TYPE=$PIECE($GET(LIST(CDRG)),U,1)
- +5 SET IEN=$PIECE($GET(LIST(CDRG)),U,2)
- +6 IF '+IEN
- QUIT
- +7 SET GIEN=$SELECT(TYPE="SOL":$$GET1^DIQ(52.7,IEN,1,"I"),TYPE="ADD":$$GET1^DIQ(52.6,IEN,1,"I"),TYPE="DD":IEN,1:"")
- +8 SET NAME=$$GET1^DIQ(50,GIEN,20)
- +9 IF NAME=VANAME
- SET DMATCH=1
- DO ROUTE(DRG,GIEN)
- End DoDot:1
- +10 IF DMATCH=0&(SMATCH=0)&(RMATCH=0)
- SET DATA(1)="-1^Scanned Drug Not Found in Virtual Due List^Wrong Drug ^"_DNAME
- QUIT
- +11 IF DMATCH=1&(RMATCH=0)&(SMATCH=0)
- SET DATA(1)="-1^Scanned Drug dose does not match route ordered^Wrong Route ^"_DNAME
- QUIT
- +12 IF DMATCH=1&(RMATCH=1)&(SMATCH=0)
- SET DATA(1)="-1^Scanned Drug does not match dose ordered^Wrong Dose ^"_DNAME
- QUIT
- +13 IF DMATCH=1&(RMATCH=1)&(SMATCH=1)
- SET DATA(1)="-1^Idential match is not found.Please use Unable to Scan option ^Not Identical ^"_DNAME
- +14 QUIT
- STRENGTH(DRG,GIEN) ;EP -see if the strength matches
- +1 NEW VASTR,DRSTR1
- +2 SET VASTR=$$GET1^DIQ(50,DRG,901)
- +3 SET DRSTR=$$GET1^DIQ(50,GIEN,901)
- +4 IF VASTR=""&(DRSTR="")
- Begin DoDot:1
- +5 SET VASTR=$$GET1^DIQ(50,DRG,21,"I")
- +6 SET DRSTR=$$GET1^DIQ(50,GIEN,21,"I")
- End DoDot:1
- +7 IF VASTR=DRSTR
- SET SMATCH=1
- +8 QUIT
- ROUTE(DRG,GIEN) ;EP- See if the route matches
- +1 NEW VAROU,DRROU,POI,POI2
- +2 SET POI=$$GET1^DIQ(50,DRG,2.1,"I")
- +3 SET POI2=$$GET1^DIQ(50,GIEN,2.1,"I")
- +4 SET VAROU=$$GET1^DIQ(50.7,POI,.06)
- +5 SET DRROU=$$GET1^DIQ(50.7,POI2,.06)
- +6 IF VAROU=DRROU
- SET RMATCH=1
- DO STRENGTH(DRG,GIEN)
- +7 QUIT
- +8 ;For IV barcodes, check that the patient matches
- +9 ;If pt matches then find the bag number in file 55
- +10 ;If its there, compare it to items on the VDL
- +11 ;Inp= CNT from calling program
- +12 ; STRING= Scanned barcode
- +13 ; TAB = BCMA tab (PBTAB,IVTAB)
- IVCHK(DATA,CNT,STRING,TAB,DFN) ;EP- Check for IV bag barcode match
- +1 IF STRING["V"!(STRING["W")
- Begin DoDot:1
- +2 IF DFN'=""
- Begin DoDot:2
- +3 IF DFN=+STRING
- DO CHKIV
- QUIT
- +4 IF DFN'=+STRING
- SET DATA(CNT)="-1^Scanned drug does not match patient^Wrong Patient"
- End DoDot:2
- End DoDot:1
- +5 IF '$TEST
- IF STRING?.N
- Begin DoDot:1
- +6 IF $GET(DFN)
- DO CHKDRG
- End DoDot:1
- +7 QUIT
- +8 ;
- CHKDRG ;EP-
- +1 NEW SLIST,ALIST,SOL,ADD,DD,ERR,CNT,IEN,ERRTXT,ERRTXT2,NAME
- +2 SET ERR=0
- SET CNT=0
- +3 KILL LIST
- +4 SET NAME=$$GET1^DIQ(50,STRING,.01)
- +5 DO GETLST(.SLIST,.ALIST)
- +6 SET INP=STRING
- +7 SET SOL=0
- FOR
- SET SOL=$ORDER(SLIST(SOL))
- IF SOL=""
- QUIT
- Begin DoDot:1
- +8 SET IEN=$GET(SLIST(SOL))
- +9 IF IEN'=""
- Begin DoDot:2
- +10 SET DD=$PIECE($GET(^PS(52.7,IEN,0)),U,2)
- +11 SET CNT=CNT+1
- +12 SET LIST(CNT)="DD^"_DD
- End DoDot:2
- End DoDot:1
- +13 SET ADD=0
- FOR
- SET ADD=$ORDER(ALIST(ADD))
- IF ADD=""
- QUIT
- Begin DoDot:1
- +14 SET IEN=$GET(ALIST(ADD))
- +15 IF IEN'=""
- Begin DoDot:2
- +16 SET DD=$PIECE($GET(^PS(52.6,IEN,0)),U,2)
- +17 SET CNT=CNT+1
- +18 SET LIST(CNT)="DD^"_DD
- End DoDot:2
- End DoDot:1
- +19 DO EN(.ERR,INP,DFN,.LIST)
- +20 QUIT
- CHKIV ;EP- Find the item in pts list
- +1 NEW IEN,BAG,DONE,LIST,ADDIEN,SOLIEN,SLIST,ALIST,RETURN,ERR
- +2 SET DONE=0
- SET DATA=""
- SET ERR=0
- +3 SET IEN=0
- FOR
- SET IEN=$ORDER(^PS(55,DFN,"IVBCMA",IEN))
- IF IEN=""!(DONE=1)
- QUIT
- Begin DoDot:1
- +4 SET BAG=$PIECE($GET(^PS(55,DFN,"IVBCMA",IEN,0)),U,1)
- +5 IF BAG=STRING
- Begin DoDot:2
- +6 SET DONE=1
- +7 DO GETLST(.SLIST,.ALIST)
- +8 SET SOL=0
- FOR
- SET SOL=$ORDER(^PS(55,DFN,"IVBCMA",IEN,"SOL",SOL))
- IF SOL=""!(ERR=1)
- QUIT
- Begin DoDot:3
- +9 SET SOLIEN=$PIECE($GET(^PS(55,DFN,"IVBCMA",IEN,"SOL",SOL,0)),U,1)
- +10 SET INP="SOL^"_SOLIEN
- +11 DO EN(.RETURN,INP,DFN,.SLIST)
- +12 IF $DATA(RETURN(1))
- SET ERR=1
- SET DATA(CNT)=RETURN(1)
- End DoDot:3
- +13 IF ERR=1
- QUIT
- +14 SET ADD=0
- FOR
- SET ADD=$ORDER(^PS(55,DFN,"IVBCMA",IEN,"AD",ADD))
- IF ADD=""!(ERR=1)
- QUIT
- Begin DoDot:3
- +15 SET ADDIEN=$PIECE($GET(^PS(55,DFN,"IVBCMA",IEN,"AD",ADD,0)),U,1)
- +16 SET INP="ADD^"_ADDIEN
- +17 DO EN(.RETURN,INP,DFN,.ALIST)
- +18 IF $DATA(RETURN(1))
- SET ERR=1
- SET DATA(CNT)=RETURN(1)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +19 IF DONE=0
- SET DATA(CNT)="-1^Drug Not Found in Virtual Due List^Wrong Drug"
- +20 QUIT
- GETLST(SLIST,ALIST) ;EP- Get list of solutions and additives
- +1 NEW SIEN,AIEN,RESULTS,NODE,CNT2
- +2 SET CNT2=1
- +3 KILL ^TMP("PSB",$JOB)
- +4 DO RPC^PSBVDLTB(.RESULTS,DFN,TAB)
- +5 SET NUM=$GET(@RESULTS@(0))
- +6 FOR I=2:1:NUM
- Begin DoDot:1
- +7 SET NODE=$GET(@RESULTS@(I))
- +8 IF $PIECE(NODE,U,1)="SOL"
- SET SLIST(CNT2)=$PIECE(NODE,U,2)
- +9 IF $PIECE(NODE,U,1)="ADD"
- SET ALIST(CNT2)=$PIECE(NODE,U,2)
- +10 IF $PIECE(NODE,U,1)="END"
- SET CNT2=CNT2+1
- End DoDot:1
- +11 QUIT