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

BDGCPT.m

Go to the documentation of this file. 
  1. BDGCPT ; IHS/ANMC/LJF - LIST CPT CODES FOR INPT STAY ;  [ 07/22/2002  1:16 PM ]
  1.  ;;5.3;PIMS;;APR 26, 2002
  1.  ;
  1.  ;follows printing of Final A Sheet
  1.  ;incoming variables:
  1.  ;  DFN = IEN of patient
  1.  ;  DGPMCA = IEN in file 405 for admission
  1.  ;  BDGFIN = 2 for full CPT listing with all providers, cpt codes
  1.  ;                tran codes, radiology, medications, supplies, labs
  1.  ;                and immunizations
  1.  ;         = 3 for Medicare/Medicaid listing which only includes
  1.  ;                radiology, tran codes and cpt codes
  1.  ;
  1.  K ^TMP("BDGCPT",$J)
  1.  NEW DGV,DGVN,DGVV,DGI
  1.  S DGV=$$GET1^DIQ(405,DGPMCA,.27,"I") Q:'DGV  ;visit ien
  1.  ;
  1.  ; -- find v file entries for hosp
  1.  S DGVV=DGV
  1.  I BDGFIN=3 F DGI="RAD","TRAN","CPT" D @DGI I 1  ;medicare a sheet
  1.  E  F DGI="PRV","CPT","TRAN","RAD","MED","SUP","LAB","IMM" D @DGI
  1.  ;
  1.  ; -- find all I visits during hosp and related v file entries
  1.  S DGVN=0 F  S DGVN=$O(^AUPNVSIT("AD",DGV,DGVN)) Q:'DGVN  D
  1.  . S DGVV=DGVN
  1.  . I BDGFIN=3 F DGI="RAD","TRAN","CPT" D @DGI I 1  ;medicare a sheet
  1.  . E  F DGI="CPT","TRAN","RAD","MED","SUP","LAB","IMM" D @DGI
  1.  ;
  1.  ; -- find all other visits during hosp
  1.  D AMB^BDGCPT1
  1.  ;
  1.  ; -- print report
  1.  D HEAD
  1.  I BDGFIN=3 F DGI="RAD","TRAN","CPT" D PRINT I 1
  1.  E  F DGI="VSIT","CPT","TRAN","PRV","RAD","MED","SUP","LAB","IMM" D PRINT
  1.  K ^TMP("BDGCPT",$J)
  1.  Q
  1.  ;
  1. PRINT ; -- print line
  1.  Q:'$D(^TMP("BDGCPT",$J,DGI))
  1.  D HDG2(DGI)
  1.  S DGDT=0
  1.  F  S DGDT=$O(^TMP("BDGCPT",$J,DGI,DGDT)) W:DGDT="" !! Q:DGDT=""  D
  1.  . S DGN=0  F  S DGN=$O(^TMP("BDGCPT",$J,DGI,DGDT,DGN)) Q:DGN=""  D
  1.  .. W !,^TMP("BDGCPT",$J,DGI,DGDT,DGN)
  1.  .. I $Y>(IOSL-4)  D HEAD
  1.  Q
  1.  ;
  1. TRAN ; -- find all trans codes
  1.  I BDGFIN=3 D TRAN^BDGCPT1 Q  ;M/M style trans code section
  1.  NEW DGN,DGDT,LINE,TRAN
  1.  S DGN=0 F  S DGN=$O(^AUPNVTC("AD",DGVV,DGN)) Q:'DGN  D
  1.  . S DGDT=$$DATE(9000010.33,DGN),LINE=$$FMTE^XLFDT(DGDT,"D")
  1.  . S LINE=LINE_" "_$$AMB(DGVV)  ;is trans code from amb visit?
  1.  . S LINE=$$PAD(LINE,17)_"HCPCS: "_$$GET1^DIQ(9000010.33,DGN,.07)
  1.  . S LINE=$$PAD(LINE_$$GET1^DIQ(9000010.33,DGN,.08),31)  ;cpt modfier
  1.  . S TRAN=$$GET1^DIQ(9000010.33,DGN,.01)
  1.  . S LINE=$$PAD(LINE,34)_"TRANS: "_$$GET1^DIQ(9000010.33,DGN,.01)
  1.  . S LINE=$$PAD(LINE,52)_$E($$GET1^DIQ(9000010.33,DGN,.11),1,27)
  1.  . D SET(LINE,"TRAN",TRAN_":"_DGDT,DGN)
  1.  Q
  1.  ;
  1. PRV ; -- find all providers
  1.  D PRV^BDGCPT1 Q
  1.  ;
  1. RAD ; -- find all v radiology entries
  1.  NEW DGN,DGDT,LINE
  1.  S DGN=0 F  S DGN=$O(^AUPNVRAD("AD",DGVV,DGN)) Q:'DGN  D
  1.  . S DGDT=$$DATE(9000010.22,DGN),LINE=$$FMTE^XLFDT(DGDT,"D")
  1.  . S LINE=LINE_" "_$$AMB(DGVV)  ;is xray from amb visit
  1.  . S LINE=$$PAD(LINE,17)_"CPT: "_$$GET1^DIQ(9000010.22,DGN,.019)
  1.  . S LINE=$$PAD(LINE,30)_$E($$GET1^DIQ(9000010.22,DGN,.01),1,18)
  1.  . S LINE=$$PAD(LINE,50)_"DX: "_$$GET1^DIQ(9000010.22,DGN,.06)  ;dx
  1.  . S LINE=$$PAD(LINE,60)_$E($$GET1^DIQ(9000010.22,DGN,1204),1,20)
  1.  . D SET(LINE,"RAD",DGDT,DGN)
  1.  Q
  1.  ;
  1. MED ; -- find all v med entries
  1.  ;
  1.  ; -- get pyxis unit dose meds
  1.  NEW IEN,DATE,LINE,RDT,LAST,ARRAY,ARRAY1,DRUGID,QTY,MEDSTN
  1.  ;
  1.  ; start at discharge date or today if still an inpatient
  1.  ;7/18/02 WAR - REMd next line and changed code per LJF14
  1.  ;S RDT=9999999-($S($$DSCDT^ADGU1(DGPMCA)]"":$$DSCDT^ADGU1(DGPMCA),1:DT))-1
  1.  S RDT=9999999-($S($$DSCDT(DGPMCA)]"":$$DSCDT(DGPMCA),1:DT))-1  ;LJF14
  1.  S LAST=9999999-$P($$GET1^DIQ(405,DGPMCA,.01,"I"),".")
  1.  F  S RDT=$O(^VEFS(19234.2,"AA",DFN,RDT)) Q:'RDT  Q:(RDT>LAST)  D
  1.  . K ARRAY,ARRAY1            ;arrays for grouping same drug on same day
  1.  . ;
  1.  . ;  for each date count up quantities by drug id #
  1.  . S IEN=0 F  S IEN=$O(^VEFS(19234.2,"AA",DFN,RDT,IEN)) Q:'IEN  D
  1.  .. S QTY=$$GET1^DIQ(19234.2,IEN,.05)
  1.  .. S DRUGID=$$GET1^DIQ(19234.2,IEN,6)
  1.  .. S MEDSTN=$$GET1^DIQ(19234.2,IEN,5.01) S:MEDSTN="" MEDSTN=" "
  1.  .. S ARRAY(DRUGID,MEDSTN)=$G(ARRAY(DRUGID,MEDSTN))+QTY
  1.  .. S:'$D(ARRAY1(DRUGID,MEDSTN)) ARRAY1(DRUGID,MEDSTN)=$$GET1^DIQ(19234.2,IEN,.01)
  1.  . ;
  1.  . ; -- now set display line for each drug for this date
  1.  . S DRUGID=0 F  S DRUGID=$O(ARRAY(DRUGID)) Q:DRUGID=""  D
  1.  .. S MEDSTN=0  F  S MEDSTN=$O(ARRAY(DRUGID,MEDSTN)) Q:MEDSTN=""  D
  1.  ... S DATE=9999999-RDT,LINE=$$FMTE^XLFDT(DATE,"D")
  1.  ... S LINE=$$PAD(LINE,15)_$E(ARRAY1(DRUGID,MEDSTN),1,30)  ;drug name
  1.  ... S LINE=$$PAD(LINE,48)_"QTY: "_ARRAY(DRUGID,MEDSTN)
  1.  ... S LINE=$$PAD(LINE,57)_"ID: "_DRUGID
  1.  ... S LINE=$$PAD(LINE,70)_$E(MEDSTN,1,10)
  1.  ... D SET(LINE,"MED","UNIT:"_DATE_MEDSTN,DRUGID)
  1.  ;
  1.  ; -- get iv meds
  1.  NEW IEN,DATE,LINE,RDT,LAST
  1.  ;
  1.  ; start at discharge date or today if still an inpatient
  1.  ;7/18/02 WAR - REMd next line and changed code per LJF14
  1.  ;S RDT=9999999-($S($$DSCDT^ADGU1(DGPMCA)]"":$$DSCDT^ADGU1(DGPMCA),1:DT))-1
  1.  S RDT=9999999-($S($$DSCDT(DGPMCA)]"":$$DSCDT(DGPMCA),1:DT))-1  ;LJF14
  1.  S LAST=9999999-$P($$GET1^DIQ(405,DGPMCA,.01,"I"),".")
  1.  F  S RDT=$O(^VEFS(19234.35,"AA",DFN,RDT)) Q:'RDT  Q:((RDT\1)>LAST)  D
  1.  . S IEN=0 F  S IEN=$O(^VEFS(19234.35,"AA",DFN,RDT,IEN)) Q:'IEN  D
  1.  .. ;
  1.  .. ; set up display line for IV drug
  1.  .. S DATE=9999999-RDT,LINE=$$FMTE^XLFDT(DATE,"D")
  1.  .. S LINE=$$PAD(LINE,15)_"IV: "_$$GET1^DIQ(19234.35,IEN,.01)
  1.  .. S LINE=$$PAD(LINE,30)_"QTY: "_$$GET1^DIQ(19234.35,IEN,.05)
  1.  .. S LINE=$$PAD(LINE,40)_$$GET1^DIQ(19234.35,IEN,2.01)  ;solution
  1.  .. S LINE=$$PAD(LINE,72)_$$GET1^DIQ(19234.35,IEN,2.02)  ;volume
  1.  .. D SET(LINE,"MED","IV:"_DATE,IEN)
  1.  .. ;
  1.  .. ; then set up possible multiple lines for additives
  1.  .. K ARRAY D ENPM^XBDIQ1(19234.351,IEN_",0",".01;.02","ARRAY(")
  1.  .. S X=0 F  S X=$O(ARRAY(X)) Q:'X  D
  1.  ... S LINE=$$SP(30)_"ADDITIVE: "_$G(ARRAY(X,.01))_"  "_$G(ARRAY(X,.02))
  1.  ... D SET(LINE,"MED","IV:"_DATE,IEN_"."_X)
  1.  ;
  1.  ; -- get discharge meds
  1.  NEW DGN,DGDT,LINE
  1.  S DGN=0 F  S DGN=$O(^AUPNVMED("AD",DGVV,DGN)) Q:'DGN  D
  1.  . S DGDT=$$DATE(9000010.14,DGN),LINE=$$FMTE^XLFDT(DGDT,"D")
  1.  . S LINE=$$PAD(LINE,15)_$E($$GET1^DIQ(9000010.14,DGN,.01),1,25)
  1.  . S LINE=$$PAD(LINE,45)_"QTY: "_$$GET1^DIQ(9000010.14,DGN,.06)
  1.  . S LINE=$$PAD(LINE,55)_$E($$GET1^DIQ(9000010.14,DGN,.05),1,25)  ;sig
  1.  . D SET(LINE,"MED","Z"_DGDT,DGN)
  1.  Q
  1.  ;
  1. SUP ; -- get pyxis supply items
  1.  NEW IEN,DATE,LINE,RDT,LAST,TOTAL,QTY
  1.  S TOTAL=0                             ;total cost of all supply items
  1.  ;
  1.  ; start at discharge date or today if still an inpatient
  1.  ;7/18/02 WAR - REMd next line and changed code per LJF14
  1.  ;S RDT=9999999-($S($$DSCDT^ADGU1(DGPMCA)]"":$$DSCDT^ADGU1(DGPMCA),1:DT))-1
  1.  S RDT=9999999-($S($$DSCDT(DGPMCA)]"":$$DSCDT(DGPMCA),1:DT))-1  ;LJF14
  1.  S LAST=9999999-$P($$GET1^DIQ(405,DGPMCA,.01,"I"),".")
  1.  F  S RDT=$O(^VEFS(19234.3,"AA",DFN,RDT)) Q:'RDT  Q:((RDT\1)>LAST)  D
  1.  . S IEN=0 F  S IEN=$O(^VEFS(19234.3,"AA",DFN,RDT,IEN)) Q:'IEN  D
  1.  .. ;
  1.  .. S DATE=9999999-RDT,LINE=$$FMTE^XLFDT(DATE,"D")
  1.  .. S LINE=$$PAD(LINE,15)_$$GET1^DIQ(19234.3,IEN,.01)_": "  ;id
  1.  .. S LINE=LINE_$$GET1^DIQ(19234.3,IEN,.1)                  ;item
  1.  .. S QTY=$$GET1^DIQ(19234.3,IEN,.05)
  1.  .. S LINE=$$PAD(LINE,55)_"QTY: "_QTY
  1.  .. S LINE=$$PAD(LINE,65)_"COST: "_$J($$COST(IEN,QTY,.TOTAL),7,2)
  1.  .. D SET(LINE,"SUP",DATE,IEN)
  1.  ;
  1.  I $D(LINE) D SET($$SP(59)_"TOTAL COST: "_$J(TOTAL,7,2),"SUP",9999999,TOTAL)
  1.  Q
  1.  ;
  1. COST(IEN,QTY,TOTAL) ; -- find total cost for supply item(s)
  1.  NEW ITEM,UNITCOST
  1.  S ITEM=$O(^DIZ(111700,"B",+$$GET1^DIQ(19234.3,IEN,.01,"I"),0))
  1.  I 'ITEM Q 0
  1.  S UNITCOST=$$GET1^DIQ(111700,ITEM,.07)
  1.  S TOTAL=TOTAL+(QTY*UNITCOST)
  1.  Q QTY*UNITCOST
  1.  ;
  1. CPT ; -- find all v cpt entries
  1.  NEW DGN,DGDT,LINE
  1.  S DGN=0 F  S DGN=$O(^AUPNVCPT("AD",DGVV,DGN)) Q:'DGN  D
  1.  . S DGDT=$$DATE(9000010.18,DGN),LINE=$$FMTE^XLFDT(DGDT,"D")
  1.  . S LINE=$$PAD(LINE,15)_$$GET1^DIQ(9000010.18,DGN,.01)
  1.  . S LINE=$$PAD(LINE_$$GET1^DIQ(9000010.18,DGN,.08),22)  ;cpt modfier
  1.  . S LINE=LINE_" "_$E($$GET1^DIQ(9000010.18,DGN,.019),1,17)
  1.  . S LINE=$$PAD(LINE,42)_"QTY: "_$$GET1^DIQ(9000010.18,DGN,.16)
  1.  . S LINE=$$PAD(LINE,50)_"DX: "_$$GET1^DIQ(9000010.18,DGN,.05)
  1.  . S LINE=$$PAD(LINE,60)_$E($$GET1^DIQ(9000010.18,DGN,1204),1,18)
  1.  . D SET(LINE,"CPT",DGDT,DGN)
  1.  Q
  1.  ;
  1. IMM ; -- find all v immunization entries
  1.  NEW DGN,DGDT,LINE
  1.  S DGN=0 F  S DGN=$O(^AUPNVIMM("AD",DGVV,DGN)) Q:'DGN  D
  1.  . S DGDT=$$DATE(9000010.11,DGN),LINE=$$FMTE^XLFDT(DGDT,"D")
  1.  . S LINE=$$PAD(LINE,15)_"CPT: "_$$GET1^DIQ(9000010.11,DGN,.011)
  1.  . S LINE=$$PAD(LINE,30)_$$GET1^DIQ(9000010.11,DGN,.01)  ;immun
  1.  . D SET(LINE,"IMM",DGDT,DGN)
  1.  Q
  1.  ;
  1. LAB ; -- find all v lab entries
  1.  NEW DGN,DGDT,LINE,CPT,FIELD,X
  1.  S DGN=0 F  S DGN=$O(^AUPNVLAB("AD",DGVV,DGN)) Q:'DGN  D
  1.  . ;
  1.  . ;include only billabel labs:
  1.  . ;     if have cpt check routine
  1.  . I $L($T(EN^LRZBILL)) D  Q:CPT=0
  1.  .. S CPT=$$EN^LRZBILL(DGN)
  1.  . ;
  1.  . ;     or do manual search in V Lab
  1.  . E  D  Q:CPT=0
  1.  .. S CPT=$$GET1^DIQ(9000010.09,DGN,1402)
  1.  .. I CPT="",$$GET1^DIQ(9000010.09,DGN,1208)]"" S CPT=0 Q  ;on panel
  1.  .. I $$GET1^DIQ(9000010.09,DGN,.04)="canc" S CPT=0 Q  ;cancelled test
  1.  .. I $$GET1^DIQ(9000010.09,DGN,1109)'="RESULTED" S CPT=0 Q  ;no result
  1.  . ;
  1.  . ; build display line
  1.  . S DGDT=$$DATE(9000010.09,DGN),LINE=$$FMTE^XLFDT(DGDT,"D")
  1.  . S LINE=LINE_" "_$$AMB(DGVV)  ;ambulatory visit lab?
  1.  . S LINE=$$PAD(LINE,17)_"CPT: "_CPT
  1.  . S LINE=$$PAD(LINE,30)_$E($$GET1^DIQ(9000010.09,DGN,.01),1,35)
  1.  . D SET(LINE,"LAB",DGDT,"LAB"_DGN)
  1.  . F FIELD=1301,1302,1303 D  ;comments
  1.  .. S X=$$GET1^DIQ(9000010.09,DGN,FIELD) Q:X=""
  1.  .. I FIELD=1301,(X["CANCELLED TEST") S Y=$$GET1^DIQ(9000010.09,DGN,.04) I (Y]""),(Y'="canc") Q  ;no comment if part of panel cancelled but this has result
  1.  .. D SET($$SP(20)_X,"LAB",DGDT,"LAB"_DGN_"."_FIELD)
  1.  ;
  1.  ; find micro data
  1.  S DGN=0 F  S DGN=$O(^AUPNVMIC("AD",DGVV,DGN)) Q:'DGN  D
  1.  . S CPT=$$GET1^DIQ(9000010.25,DGN,1402)
  1.  . I CPT="",$$GET1^DIQ(9000010.25,DGN,1208)]"" Q  ;part of panel
  1.  . I $$GET1^DIQ(9000010.25,DGN,1109)'="RESULTED" Q  ;resulted only
  1.  . S DGDT=$$DATE(9000010.25,DGN),LINE=$$FMTE^XLFDT(DGDT,"D")
  1.  . S LINE=LINE_" "_$$AMB(DGVV)
  1.  . S LINE=$$PAD(LINE,17)_"CPT: "_$P(CPT,"|")
  1.  . S LINE=$$PAD(LINE,30)_$E($$GET1^DIQ(9000010.25,DGN,.01),1,35)
  1.  . D SET(LINE,"LAB",DGDT,"MICRO"_DGN)
  1.  Q
  1.  ;
  1. DATE(FILE,IEN) ; -- find date for item
  1.  NEW DATE
  1.  S DATE=$$GET1^DIQ(FILE,IEN,1201,"I") I DATE]"" Q DATE  ;event date
  1.  S DATE=$$GET1^DIQ(FILE,IEN,.03,"I")  ;visit ien
  1.  S DATE=$$GET1^DIQ(9000010,DATE,.01,"I")  ;visit date
  1.  Q DATE
  1.  ;
  1.  ;7/18/02 WAR - added this routine per LJF14
  1. DSCDT(ADM)  ;EP - discharge date based on admit ien
  1.  ;IHS/ANMC/LJF 7/6/2002 moved from obsolete routine ADGU1
  1.  NEW DSC
  1.  S DSC=$$GET1^DIQ(405,ADM,.17,"I") I 'DSC Q ""
  1.  Q $$GET1^DIQ(405,DSC,.01,"I")
  1.  ;
  1. AMB(V) ; -- is this visit an ambulatory one?
  1.  Q $S($$SC^APCLV(V,"I")="A":"(A)",1:"")
  1.  ;
  1. SET(LINE,SECTION,DATE,IEN) ; -- put display line into date order under section
  1.  S ^TMP("BDGCPT",$J,SECTION,DATE,IEN)=$E(LINE,1,80)
  1.  Q
  1.  ;
  1.  W @IOF W !,"CPT DATA FOR HOSPITALIZATION:  #",$$HRCN^BDGF2(DFN,DUZ(2))
  1.  W "  ",$E($$GET1^DIQ(2,DFN,.01),1,20)                 ;pt name
  1.  W "  ",$$GET1^DIQ(405,DGPMCA,.01)                       ;admit date
  1.  W !,$$REPEAT^XLFSTR("=",80),!
  1.  Q
  1.  ;
  1. HDG2(CAT) ; -- heading for each category
  1.  NEW X
  1.  F X=1:1 Q:$P($T(SECTION+X),";;",2)=""  D
  1.  . I $P($T(SECTION+X),";;",2)=CAT W !,$P($T(SECTION+X),";;",3)
  1.  Q
  1.  ;
  1. PAD(D,L) ; -- SUBRTN to pad length of data
  1.  ; -- D=data L=length
  1.  Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
  1.  ;
  1. SP(N) ; -- SUBRTN to pad N number of spaces
  1.  Q $$PAD(" ",N)
  1.  ;
  1. SECTION ;;
  1.  ;;TRAN;;Transaction Codes:;;
  1.  ;;CPT;;Miscellaneous CPT Codes:;;
  1.  ;;LAB;;Laboratory Tests:;;
  1.  ;;RAD;;Radiology Procedures:;;
  1.  ;;MED;;Medications (IV, unit dose & disch meds):;;
  1.  ;;IMM;;Immunizations:;;
  1.  ;;SUP;;Supplies:;;
  1.  ;;VSIT;;Other Visits for date range (72/24 rule):;;
  1.  ;;PRV;;Hospitalization Providers:;;