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