BGOVCPT ; IHS/BAO/TMD - Manage V CPT ;31-Mar-2016 04:49;du
;;1.1;BGO COMPONENTS;**1,3,4,5,6,8,9,11,13,14,16,17,18,20**;Mar 20, 2007;Build 2
;---------------------------------------------
TIUSTR() ;EP
N X,Y
S X=$$GETVAR^CIANBUTL("ENCOUNTER.ID.ALTERNATEVISITID",,"CONTEXT.ENCOUNTER")
Q:X="" " "
S X=$$VSTR2VIS^BEHOENCX(DFN,X)
Q:X<1 " "
D GET(.X,DFN_"^^"_X_"^^1")
S Y=$G(@X@(1))
K @X
Q $S(Y<0:"",1:Y)
; Return IEN of a CPT code
GETIEN(RET,CPT) ;EP
S RET=$O(^ICPT("BA",$G(CPT)_" ",0))
Q
; Return vaccine IEN associated with specified CPT IEN
IMMCK(RET,CPTIEN) ;EP
N X
S RET="",X=0
F S X=$O(^AUTTIMM(X)) Q:'X I $P(^(X,0),U,11)=CPTIEN,'$P(^(0),U,7) Q
S:X RET=X_U_$P(^AUTTIMM(X,0),U,2)
Q
; Return VCPT entries by patient or by visit
; INP = Patient IEN ^ Max ^ Visit IEN ^ Type ^ Format (0-detailed,1-tiu list)
; Returned as a list of records in the format:
; Visit Date [1] ^ Fac IEN [2] ^ Fac Name [3] ^ CPT [4] ^ CPT name [5] ^ Narrative [6] ^ Dx [7] ^
; Prim [8] ^ Mod1 [9] ^ Mod2 [10] ^ V File IEN [11] ^ Visit IEN [12] ^ CPT IEN [13] ^ Quantity [14] ^
; Provider Name [15] ^ Tran Code IEN [16] ^ ICD0 IEN [17] ^ Visit Locked [18] ^ V File [19]
GET(RET,INP) ;EP
N CNT,BGO,REC,COD,TRANIEN,ICD0IEN,QTY,DX,IEN,DFN,VISITIEN,FORMAT,TYP,MAX,VIEN,MOD1,MOD2
N CPT,CPTIEN,ITEMNAME,PNAR,TAX,PRIM,PRV,CODE,VF,ICDCNT,SCODE,ICDARRY,V2,V3,MATCH,X,Z,BHSCPT2
S RET=$$TMPGBL^BGOUTL
S CNT=0,ICDCNT=0
S DFN=+INP
Q:'DFN
S MAX=$P(INP,U,2)
S:'MAX MAX=9999
S VISITIEN=+$P(INP,U,3)
S TYP=$$UP^XLFSTR($P(INP,U,4))
S FORMAT=+$P(INP,U,5)
S IEN=0
D G1:VISITIEN,G0:'VISITIEN
Q
; By patient
G0 I TYP'="DENTAL" D
.F S IEN=$O(^AUPNVCPT("C",DFN,IEN)) Q:'IEN Q:CNT>MAX D CPTBLD(1)
I TYP="DENTAL" D
.F S IEN=$O(^AUPNVDEN("AC",DFN,IEN)) Q:'IEN Q:CNT>MAX D DENBLD
I TYP="SURGICAL"!(TYP="ALL") D
.F S IEN=$O(^AUPNVPRC("AC",DFN,IEN)) Q:'IEN Q:CNT>MAX D PRCBLD(1)
Q
; By visit
G1 I TYP="DENTAL" D
.F S IEN=$O(^AUPNVDEN("AD",VISITIEN,IEN)) Q:'IEN Q:CNT>MAX D DENBLD
F S IEN=$O(^AUPNVCPT("AD",VISITIEN,IEN)) Q:'IEN Q:CNT>MAX D CPTBLD(0)
F S IEN=$O(^AUPNVTC("AD",VISITIEN,IEN)) Q:'IEN Q:CNT>MAX D TRANBLD
F S IEN=$O(^AUPNVPRC("AD",VISITIEN,IEN)) Q:'IEN Q:CNT>MAX D PRCBLD(0)
Q
; VCPT
CPTBLD(SRCH) ;EP- Find CPTs
D INIT("CPT")
S REC=$G(^AUPNVCPT(IEN,0))
Q:REC=""
I FORMAT D Q
.S CPTIEN=$P(REC,U) Q:CPTIEN=""
.I CPTIEN>99200,CPTIEN<99500 Q
.S PNAR=$P($G(^ICPT(CPTIEN,0)),U,2)
.I $P(REC,U,4) S PNAR=$P($G(^AUTNPOV($P(REC,U,4),0)),U)
.S CNT=CNT+1
.S ^TMP("BGOVCPT",$J,1)=$S(CNT=1:"",1:^TMP("BGOVCPT",$J,1)_"; ")_PNAR
S CPTIEN=$P(REC,U) Q:CPTIEN=""
S VIEN=$P(REC,U,3)
S V2=$P($G(^AUPNVSIT(VIEN,0)),U)
S PNAR=$P(REC,U,4)
S DX=$P(REC,U,5)
S QTY=$P(REC,U,16)
S PRIM=$P(REC,U,7)
I $G(DUZ("AG"))="I" D ;P6
.S MOD1=$P(REC,U,8)
.S MOD2=$P(REC,U,9)
E D
.N X
.S X=+$O(^AUPNVCPT(IEN,1,0)),MOD1=$P($G(^(X,0)),U)
.S X=+$O(^AUPNVCPT(IEN,1,X)),MOD2=$P($G(^(X,0)),U)
S PRV=$P($G(^AUPNVCPT(IEN,12)),U,4)
S CODE=$P($G(^ICPT(CPTIEN,0)),U)
Q:CODE=""
;IHS/MSC/MGH Added check for taxonomy to display surgical procedures Patch 11
S TAX=$O(^ATXAX("B","APCH HS MAJOR PROCEDURE CPTS",0))
I TYP="SURGICAL",((CODE<10000)&(CODE'="00099"))!(CODE>69999) Q
;IHS/MSC/MGH Patch 18
I TYP="SURGICAL",SRCH=1,'$$ICD^ATXAPI(CODE,TAX,1) Q ;Not a CPT on this component
I TYP="MEDICAL",CODE<90000!(CODE>99999) Q
I TYP="ANESTHESIA",CODE>9999!(+CODE=0)!(CODE="00099") Q
I TYP="RADIOLOGY",CODE<70000!(CODE>79999) Q
I TYP="LABORATORY",CODE<80000!(CODE>89999) Q
I TYP="MISCELLANEOUS",CODE'?1A4N Q
S ITEMNAME=$P($G(^ICPT(CPTIEN,0)),U,2)
D ARRAY
;MSC/IHS/MGH If there is a corresponding ICD0 code, save it for lookup later
I $D(^ICPT(CPTIEN,"ICD",0)) D
.S SCODE=0 F S SCODE=$O(^ICPT(CPTIEN,"ICD",SCODE)) Q:SCODE=""!(SCODE="B") D
..S ICDARRY(SCODE)=CODE_"^"_V2
Q
; Build dental history
DENBLD N ADA
D INIT("DEN")
S REC=$G(^AUPNVDEN(IEN,0))
Q:REC=""
S ADA=$P(^AUTTADA(+REC,0),U)
Q:'ADA
S CPTIEN=$O(^ICPT("B",ADA,0))
Q:'CPTIEN
S CODE=$P($G(^ICPT(CPTIEN,0)),U)
Q:CODE=""
S ITEMNAME=$P($G(^ICPT(CPTIEN,0)),U,2)
S VIEN=$P(REC,U,3)
Q:VIEN=""
S PRV=$P($G(^AUPNVDEN(IEN,12)),U,4)
D ARRAY
Q
; Interface with V TRANSACTION CODE file
TRANBLD D INIT("TC")
S REC=$G(^AUPNVTC(IEN,0))
Q:REC=""
S TRANIEN=$P(REC,U)
Q:TRANIEN=""
S CODE=$P($G(^BCMTCF(TRANIEN,0)),U)
S VIEN=$P(REC,U,3)
S ITEMNAME=$P($G(^BCMTCF(TRANIEN,0)),U,7)
S MOD1=$P(REC,U,8)
S PRV=$P($G(^AUPNVTC(IEN,12)),U,4)
D ARRAY
Q
; Interface with V PROCEDURE file
PRCBLD(SRCH) N SKIP,X,Y,ICODE
D INIT("PRC")
S REC=$G(^AUPNVPRC(IEN,0))
Q:REC=""
S ICD0IEN=$P(REC,U)
Q:ICD0IEN=""
S VIEN=$P(REC,U,3)
S V3=$P($G(^AUPNVSIT(VIEN,0)),U)
S DX=$P(REC,U,5)
S PNAR=$P(REC,U,4)
S PRV=$P($G(^AUPNVPRC(IEN,12)),U,4)
;IHS/MSC/MGH Changed the 2 to a 1 to return the proper field Patch 17
I $$AICD^BGOUTL2 S CODE=$P($$ICDOP^ICDEX(ICD0IEN,V3,"","I"),U,2)
E S CODE=$P($G(^ICD0(ICD0IEN,0)),U)
Q:CODE=""
; Do not include ICD procedures that correspond to CPT procedures
S (X,SKIP)=0
;IHS/MSC/MGH Use the saved array to check for matching codes and dates
I 'VISITIEN D
.S ICODE=0 F S ICODE=$O(ICDARRY(ICODE)) Q:ICODE="" D
..I ICD0IEN=ICODE&($P($G(ICDARRY(ICODE)),U,2)=V3) S SKIP=1 Q
E D
.F S X=$O(^ICPT("I",ICD0IEN,X)) Q:'X D Q:SKIP
..S Y=0
..F S Y=$O(^AUPNVCPT("AD",VISITIEN,Y)) Q:'Y I +^AUPNVCPT(Y,0)=X S SKIP=1 Q
Q:SKIP
I TYP="SURGICAL" D Q:SKIP
.S SKIP=1
.;Patch 16 changed lookup
.I SRCH,$$ICD^ATXAPI(ICD0IEN,$O(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)),0) Q
.;Q:CODE\1>85
.;Q:CODE=69.7
.;Q:CODE\1=23
.;Q:CODE\1=24
.S SKIP=0
I $$AICD^BGOUTL2 S ITEMNAME=$P($$ICDOP^ICDEX(ICD0IEN,V3,"","I"),U,5)
E S ITEMNAME=$P($$ICDOP^ICDCODE(ICD0IEN,V3),U,5)
;S ITEMNAME=$P($G(^ICD0(ICD0IEN,0)),U,4)
D ARRAY
Q
INIT(X) S (CPT,ITEMNAME,PNAR,DX,PRIM,MOD1,MOD2,VIEN,CPTIEN,QTY,PRV,TRANIEN,ICD0IEN)="",VF=X
Q
ARRAY N F,V,VDATE,FAC,FACNAM
S F=$P($G(^AUPNVSIT(VIEN,0)),U,6)
S FAC=$P($G(^AUTTLOC(+F,0)),U,10)
S FACNAM=$P($G(^AUTTLOC(+F,0)),U)
S FACNAM=$P($G(^DIC(4,+FACNAM,0)),U)
S:$P($G(^AUPNVSIT(VIEN,21)),U)'="" FACNAM=$P(^(21),U)
S V=$P($G(^AUPNVSIT(VIEN,0)),U)
Q:V=""
S VDATE=$$FMTDATE^BGOUTL(V)
S:PNAR PNAR=$P($G(^AUTNPOV(PNAR,0)),U)
S:PNAR="" PNAR=ITEMNAME
;S:DX DX=$P($G(^ICD9(DX,0)),U,3) ;DKA Patch 13
I DX D
.I $$AICD^BGOUTL2 S DX=$P($$ICDDX^ICDEX(DX,VDATE,"","I"),U,4)
.E S DX=$P($$ICDDX^ICDCODE(DX,VDATE),U,4)
S:PRV PRV=$P($G(^VA(200,PRV,0)),U)
S:MOD1 MOD1=MOD1_"~"_$P($G(@$$MODGBL@(MOD1,0)),U,2)
S:MOD2 MOD2=MOD2_"~"_$P($G(@$$MODGBL@(MOD2,0)),U,2)
S CNT=CNT+1
S @RET@(CNT)=VDATE_U_FAC_U_FACNAM_U_CODE_U_ITEMNAME_U_PNAR_U_DX_U_PRIM_U_MOD1_U_MOD2_U_IEN_U_VIEN_U_CPTIEN_U_QTY_U_PRV_U_TRANIEN_U_ICD0IEN_U_$$ISLOCKED^BEHOENCX(VIEN)_U_VF
Q
; Returns CPT modifier global reference
;IHS/MSC/MGH Changed for code set versioning
MODGBL() Q $S($$CSVACT^BGOUTL2():"^DIC(81.3)",$G(DUZ("AG"))="I":"^AUTTCMOD",1:"^DIC(81.3)") ;P6
; Delete a V CPT, V Procedure, or V Transaction Code entry.
; INP = IEN ^ Type
DEL(RET,INP) ;EP
N IEN,TYP,FNUM
S IEN=+INP,RET=""
I 'IEN S RET=$$ERR^BGOUTL(1008) Q
S TYP=$P(INP,U,2)
S:TYP="" TYP="CPT"
I TYP="CPT" D Q:RET<0
.N CPTIEN,ICD0IEN,VIEN,PRCIEN,X
.S X=$G(^AUPNVCPT(IEN,0)),CPTIEN=+X,VIEN=+$P(X,U,3),ICD0IEN=0
.F S ICD0IEN=$O(^ICPT(CPTIEN,"ICD",ICD0IEN)) Q:'ICD0IEN D
..S PRCIEN=0
..F S PRCIEN=$O(^AUPNVPRC("AD",VIEN,PRCIEN)) Q:'PRCIEN D Q:RET<0
...D:+$G(^AUPNVPRC(PRCIEN,0))=ICD0IEN DEL(.RET,PRCIEN_"^PRC")
S FNUM=+$P($G(@("^AUPNV"_TYP_"(0)")),U,2)
I 'FNUM S RET=$$ERR^BGOUTL(1072,TYP)
E D VFDEL^BGOUTL2(.RET,FNUM,IEN)
Q
; Set VCPT quantity
; INP = VCPT IEN ^ Quantity
SETQTY(RET,INP) ;EP
D SETVAL(.RET,+INP,$P(INP,U,2),.16)
Q
; Set VCPT diagnosis
; INP = VCPT IEN ^ Diagnosis IEN
SETDX(RET,INP) ;EP
D SETVAL(.RET,+INP,"`"_$P(INP,U,2),.05)
Q
; Set a value
SETVAL(RET,IEN,VAL,FLD) ;
N FDA
S FDA($$FNUM,IEN_",",FLD)=VAL
S RET=$$UPDATE^BGOUTL(.FDA,"E")
D:'RET VFEVT^BGOUTL2($$FNUM,IEN,1)
Q
; Checks CPT code for validity
; CPTIEN = CPT IEN
; ACTDT = Active Date
; Returns null if OK, or -n^error text
CHKCPT(CPTIEN,ACTDT,IEN) ;EP
N RET,X
S RET="",IEN=$G(IEN)
S ACTDT=$G(ACTDT,DT)
I $$CSVACT^BGOUTL2("ICPTCOD") D
.;IHS/MSC/MGH Added for HOTFIX to make sure we have the IEN and not the code
.I +IEN S CPTIEN=$$CODEN^ICPTCOD(CPTIEN)
.S X=$$CPT^ICPTCOD(CPTIEN,ACTDT)
.I X<0 S RET=$$ERR^BGOUTL(1073)
.E I '$P(X,U,7) S RET=$$ERR^BGOUTL(1074)
E D
.N DELDT
.S X=$G(^ICPT(CPTIEN,0))
.I X="" S RET=$$ERR^BGOUTL(1073) Q
.I $P(X,U,4) S RET=$$ERR^BGOUTL(1074) Q
.S DELDT=$P(X,U,7)
.I DELDT D
..S:'ACTDT ACTDT=DT
..S:$$FMDIFF^XLFDT(ACTDT,DELDT)>-1 RET=$$ERR^BGOUTL(1075)
Q RET
; Add/edit a VCPT entry
; INP = Visit IEN [1] ^ CPT IEN [2] ^ Patient IEN [3] ^ Event Date [4] ^ Quantity [5] ^ Diagnosis [6] ^
; Modifier #1 [7] ^ Provider IEN [8] ^ Principal [9] ^ V File IEN [10] ^ Narrative [11] ^ Modifier #2 [12] ^
; Location IEN [13] ^ Outside Location [14] ^ Historical [15] ^ ICD Procedure Flag [16] ^ No Dups [17]
; .RET = VCPT IEN or -n^error text if not successful
SET(RET,INP) ;EP
N VIEN,X,APCDALVR,DFN,TYPE,VFIEN,QTY,DX,MOD1,PRV,PRIN,NARR,MOD2,EVNTDT,LOCIEN,OUTLOC,HIST
N DELDT,ICD0FLG,NODUP,VCAT,FDA,FNUM,VFNEW,IEN,CHKDT,APCDOVR
S RET="",FNUM=$$FNUM
S VIEN=+INP
S TYPE=$P(INP,U,2)
S DFN=$P(INP,U,3)
S EVNTDT=$$CVTDATE^BGOUTL($P(INP,U,4))
I EVNTDT="" S EVNTDT=$P($G(^AUPNVSIT(VIEN,0)),U,1)
I EVNTDT="" S EVNTDT=$$NOW^XLFDT
S QTY=$P(INP,U,5)
S DX=$P(INP,U,6)
S MOD1=$P(INP,U,7)
S PRV=$P(INP,U,8)
S PRIN=$P(INP,U,9)
S VFIEN=$P(INP,U,10)
S VFNEW='VFIEN
S RET=$$FNDNARR^BGOUTL2($P(INP,U,11))
Q:RET<0
S NARR=$S(RET:"`"_RET,1:""),RET=""
S MOD2=$P(INP,U,12)
S LOCIEN=$P(INP,U,13)
S OUTLOC=$P(INP,U,14)
S HIST=$P(INP,U,15)
;IHS/MSC/MGH per Susan Richards this lookup is no longer supported
;S ICD0FLG=$P(INP,U,16)
S NODUP=$P(INP,U,17)
I 'VIEN,'HIST S RET=$$ERR^BGOUTL(1002) Q
S VCAT=$P($G(^AUPNVSIT(VIEN,0)),U,7)
S:VCAT="E" HIST=1
S:'TYPE TYPE=+$O(^ICPT("B","00099",0))
;IHS/MSC/MGH Dealing with old data, setting to first date
;CHANGE DATE TO 2900101 PATCH 9
I EVNTDT<2890101 S CHKDT=2890101
E S CHKDT=EVNTDT
S RET=$$CHKCPT(TYPE,CHKDT)
Q:RET<0
I HIST D Q:RET<0
.S RET=$$MAKEHIST^BGOUTL(DFN,EVNTDT,$S($L(OUTLOC):OUTLOC,1:LOCIEN),VIEN)
.S:RET>0 VIEN=RET
S RET=$$CHKVISIT^BGOUTL(VIEN,DFN)
Q:RET
I 'VFIEN D Q:RET
.I EVNTDT<DT S APCDOVR=1 ;IHS/MSC/MGH auto store if old data, Patch 9
.D VFNEW^BGOUTL2(.RET,FNUM,TYPE,VIEN,$S(NODUP:"CPT",1:""))
.S:RET>0 VFIEN=RET,RET=""
I PRIN="X"!(PRIN="") D
.S X=$$GETPRIN(VIEN)
.S PRIN=$S('X:"Y",X=VFIEN:"Y",1:"N")
S FDA=$NA(FDA(FNUM,VFIEN_","))
S @FDA@(.01)="`"_TYPE
S @FDA@(.04)=NARR
S @FDA@(.05)=$S(DX:"`"_DX,1:"@")
S @FDA@(.07)=PRIN
I $G(DUZ("AG"))="I" D ;P6
.S @FDA@(.08)=$S(MOD1:"`"_MOD1,1:"@")
.S @FDA@(.09)=$S(MOD2:"`"_MOD2,1:"@")
E D
.;IHS/MSC/MGH changes added patch 8
.I MOD1 I '$D(^AUPNVCPT(VFIEN,1,"B",MOD1)) D
..S:MOD1 FDA(9000010.181,"?+1,"_VFIEN_",",.01)="`"_MOD1
.I MOD2 I '$D(^AUPNVCPT(VFIEN,2,"B",MOD2)) D
..S:MOD2 FDA(9000010.181,"?+1,"_VFIEN_",",.01)="`"_MOD2
.S IEN(2)=1,IEN(3)=2
S @FDA@(.16)=$S(QTY>0:QTY,1:1)
S @FDA@(1201)="N"
;S @FDA@(1204)="`"_$S(PRV:PRV,1:DUZ) ; PATCH 5
S @FDA@(1204)="`"_DUZ ;PATCH 5
;Patch 11 Set date entered
I VFNEW D
.S @FDA@(1216)="N"
.S @FDA@(1217)="`"_DUZ
;Patch 11 Set last modified
S @FDA@(1218)="N"
S @FDA@(1219)="`"_DUZ
S RET=$$UPDATE^BGOUTL(.FDA,"E",.IEN)
I RET,VFNEW,$$DELETE^BGOUTL(FNUM,VFIEN)
Q:RET
S:PRIN="Y" RET=$$SETPRIN(VIEN,VFIEN)
;MSC/IHS/MGH Call to create entry in procedure file is removed in patch 5
;I 'RET,ICD0FLG D
;.N VFIEN,PRCIEN,FNUM
;.S PRCIEN=$O(^ICPT(TYPE,"ICD",0))
;.Q:'PRCIEN
;.S FNUM=9000010.08,VFIEN=0
;.D VFNEW^BGOUTL2(.RET,FNUM,PRCIEN,VIEN)
;.S:RET>0 VFIEN=RET,RET=""
;.Q:RET
;.S FDA=$NA(FDA(FNUM,VFIEN_","))
;.S @FDA@(.04)=NARR
;.S @FDA@(1201)=$S(EVNTDT:EVNTDT,1:"N")
;.;S @FDA@(1204)="`"_$S(PRV:PRV,1:DUZ) ;PATCH 5
;.S @FDA@(1204)="`"_DUZ
;.S RET=$$UPDATE^BGOUTL(.FDA,"E")
D:'RET VFEVT^BGOUTL2(FNUM,VFIEN,'VFNEW)
S:'RET RET=VFIEN
Q
; Return IEN of principal VCPT entry
GETPRIN(VIEN) ;
N VCPT
S VCPT=0
F S VCPT=$O(^AUPNVCPT("AD",VIEN,VCPT)) Q:'VCPT Q:$P($G(^AUPNVCPT(VCPT,0)),U,7)="Y"
Q VCPT
; Set principal flag for specified entry, clearing all others
SETPRIN(VIEN,VCPTIEN) ;
N VCPT,FDA
S VCPT=0
F S VCPT=$O(^AUPNVCPT("AD",VIEN,VCPT)) Q:'VCPT D
.S FDA($$FNUM,VCPT_",",.07)=$S(VCPT=VCPTIEN:"Y",1:"N")
Q $$UPDATE^BGOUTL(.FDA)
; Add CPT code
ADDCPT(CPT,ICD,VSIT,DFN,PRV) ;EP
N FDA,IEN,RET
S FDA=$NA(FDA($$FNUM,"+1,"))
S @FDA@(.01)=CPT
S @FDA@(.02)=DFN
S @FDA@(.03)=VSIT
S:$G(ICD) @FDA@(.05)=ICD
S @FDA@(.16)=1
S @FDA@(1201)=$$NOW^XLFDT
S @FDA@(1204)=$S(PRV:PRV,1:DUZ)
S RET=$$UPDATE^BGOUTL(.FDA,,.IEN)
D:'RET VFEVT^BGOUTL2($$FNUM,IEN(1),0)
Q RET
; Return V File #
FNUM() Q 9000010.18
BGOVCPT ; IHS/BAO/TMD - Manage V CPT ;31-Mar-2016 04:49;du
+1 ;;1.1;BGO COMPONENTS;**1,3,4,5,6,8,9,11,13,14,16,17,18,20**;Mar 20, 2007;Build 2
+2 ;---------------------------------------------
TIUSTR() ;EP
+1 NEW X,Y
+2 SET X=$$GETVAR^CIANBUTL("ENCOUNTER.ID.ALTERNATEVISITID",,"CONTEXT.ENCOUNTER")
+3 IF X=""
QUIT " "
+4 SET X=$$VSTR2VIS^BEHOENCX(DFN,X)
+5 IF X<1
QUIT " "
+6 DO GET(.X,DFN_"^^"_X_"^^1")
+7 SET Y=$GET(@X@(1))
+8 KILL @X
+9 QUIT $SELECT(Y<0:"",1:Y)
+10 ; Return IEN of a CPT code
GETIEN(RET,CPT) ;EP
+1 SET RET=$ORDER(^ICPT("BA",$GET(CPT)_" ",0))
+2 QUIT
+3 ; Return vaccine IEN associated with specified CPT IEN
IMMCK(RET,CPTIEN) ;EP
+1 NEW X
+2 SET RET=""
SET X=0
+3 FOR
SET X=$ORDER(^AUTTIMM(X))
IF 'X
QUIT
IF $PIECE(^(X,0),U,11)=CPTIEN
IF '$PIECE(^(0),U,7)
QUIT
+4 IF X
SET RET=X_U_$PIECE(^AUTTIMM(X,0),U,2)
+5 QUIT
+6 ; Return VCPT entries by patient or by visit
+7 ; INP = Patient IEN ^ Max ^ Visit IEN ^ Type ^ Format (0-detailed,1-tiu list)
+8 ; Returned as a list of records in the format:
+9 ; Visit Date [1] ^ Fac IEN [2] ^ Fac Name [3] ^ CPT [4] ^ CPT name [5] ^ Narrative [6] ^ Dx [7] ^
+10 ; Prim [8] ^ Mod1 [9] ^ Mod2 [10] ^ V File IEN [11] ^ Visit IEN [12] ^ CPT IEN [13] ^ Quantity [14] ^
+11 ; Provider Name [15] ^ Tran Code IEN [16] ^ ICD0 IEN [17] ^ Visit Locked [18] ^ V File [19]
GET(RET,INP) ;EP
+1 NEW CNT,BGO,REC,COD,TRANIEN,ICD0IEN,QTY,DX,IEN,DFN,VISITIEN,FORMAT,TYP,MAX,VIEN,MOD1,MOD2
+2 NEW CPT,CPTIEN,ITEMNAME,PNAR,TAX,PRIM,PRV,CODE,VF,ICDCNT,SCODE,ICDARRY,V2,V3,MATCH,X,Z,BHSCPT2
+3 SET RET=$$TMPGBL^BGOUTL
+4 SET CNT=0
SET ICDCNT=0
+5 SET DFN=+INP
+6 IF 'DFN
QUIT
+7 SET MAX=$PIECE(INP,U,2)
+8 IF 'MAX
SET MAX=9999
+9 SET VISITIEN=+$PIECE(INP,U,3)
+10 SET TYP=$$UP^XLFSTR($PIECE(INP,U,4))
+11 SET FORMAT=+$PIECE(INP,U,5)
+12 SET IEN=0
+13 IF VISITIEN
DO G1
IF 'VISITIEN
DO G0
+14 QUIT
+15 ; By patient
G0 IF TYP'="DENTAL"
Begin DoDot:1
+1 FOR
SET IEN=$ORDER(^AUPNVCPT("C",DFN,IEN))
IF 'IEN
QUIT
IF CNT>MAX
QUIT
DO CPTBLD(1)
End DoDot:1
+2 IF TYP="DENTAL"
Begin DoDot:1
+3 FOR
SET IEN=$ORDER(^AUPNVDEN("AC",DFN,IEN))
IF 'IEN
QUIT
IF CNT>MAX
QUIT
DO DENBLD
End DoDot:1
+4 IF TYP="SURGICAL"!(TYP="ALL")
Begin DoDot:1
+5 FOR
SET IEN=$ORDER(^AUPNVPRC("AC",DFN,IEN))
IF 'IEN
QUIT
IF CNT>MAX
QUIT
DO PRCBLD(1)
End DoDot:1
+6 QUIT
+7 ; By visit
G1 IF TYP="DENTAL"
Begin DoDot:1
+1 FOR
SET IEN=$ORDER(^AUPNVDEN("AD",VISITIEN,IEN))
IF 'IEN
QUIT
IF CNT>MAX
QUIT
DO DENBLD
End DoDot:1
+2 FOR
SET IEN=$ORDER(^AUPNVCPT("AD",VISITIEN,IEN))
IF 'IEN
QUIT
IF CNT>MAX
QUIT
DO CPTBLD(0)
+3 FOR
SET IEN=$ORDER(^AUPNVTC("AD",VISITIEN,IEN))
IF 'IEN
QUIT
IF CNT>MAX
QUIT
DO TRANBLD
+4 FOR
SET IEN=$ORDER(^AUPNVPRC("AD",VISITIEN,IEN))
IF 'IEN
QUIT
IF CNT>MAX
QUIT
DO PRCBLD(0)
+5 QUIT
+6 ; VCPT
CPTBLD(SRCH) ;EP- Find CPTs
+1 DO INIT("CPT")
+2 SET REC=$GET(^AUPNVCPT(IEN,0))
+3 IF REC=""
QUIT
+4 IF FORMAT
Begin DoDot:1
+5 SET CPTIEN=$PIECE(REC,U)
IF CPTIEN=""
QUIT
+6 IF CPTIEN>99200
IF CPTIEN<99500
QUIT
+7 SET PNAR=$PIECE($GET(^ICPT(CPTIEN,0)),U,2)
+8 IF $PIECE(REC,U,4)
SET PNAR=$PIECE($GET(^AUTNPOV($PIECE(REC,U,4),0)),U)
+9 SET CNT=CNT+1
+10 SET ^TMP("BGOVCPT",$JOB,1)=$SELECT(CNT=1:"",1:^TMP("BGOVCPT",$JOB,1)_"; ")_PNAR
End DoDot:1
QUIT
+11 SET CPTIEN=$PIECE(REC,U)
IF CPTIEN=""
QUIT
+12 SET VIEN=$PIECE(REC,U,3)
+13 SET V2=$PIECE($GET(^AUPNVSIT(VIEN,0)),U)
+14 SET PNAR=$PIECE(REC,U,4)
+15 SET DX=$PIECE(REC,U,5)
+16 SET QTY=$PIECE(REC,U,16)
+17 SET PRIM=$PIECE(REC,U,7)
+18 ;P6
IF $GET(DUZ("AG"))="I"
Begin DoDot:1
+19 SET MOD1=$PIECE(REC,U,8)
+20 SET MOD2=$PIECE(REC,U,9)
End DoDot:1
+21 IF '$TEST
Begin DoDot:1
+22 NEW X
+23 SET X=+$ORDER(^AUPNVCPT(IEN,1,0))
SET MOD1=$PIECE($GET(^(X,0)),U)
+24 SET X=+$ORDER(^AUPNVCPT(IEN,1,X))
SET MOD2=$PIECE($GET(^(X,0)),U)
End DoDot:1
+25 SET PRV=$PIECE($GET(^AUPNVCPT(IEN,12)),U,4)
+26 SET CODE=$PIECE($GET(^ICPT(CPTIEN,0)),U)
+27 IF CODE=""
QUIT
+28 ;IHS/MSC/MGH Added check for taxonomy to display surgical procedures Patch 11
+29 SET TAX=$ORDER(^ATXAX("B","APCH HS MAJOR PROCEDURE CPTS",0))
+30 IF TYP="SURGICAL"
IF ((CODE<10000)&(CODE'="00099"))!(CODE>69999)
QUIT
+31 ;IHS/MSC/MGH Patch 18
+32 ;Not a CPT on this component
IF TYP="SURGICAL"
IF SRCH=1
IF '$$ICD^ATXAPI(CODE,TAX,1)
QUIT
+33 IF TYP="MEDICAL"
IF CODE<90000!(CODE>99999)
QUIT
+34 IF TYP="ANESTHESIA"
IF CODE>9999!(+CODE=0)!(CODE="00099")
QUIT
+35 IF TYP="RADIOLOGY"
IF CODE<70000!(CODE>79999)
QUIT
+36 IF TYP="LABORATORY"
IF CODE<80000!(CODE>89999)
QUIT
+37 IF TYP="MISCELLANEOUS"
IF CODE'?1A4N
QUIT
+38 SET ITEMNAME=$PIECE($GET(^ICPT(CPTIEN,0)),U,2)
+39 DO ARRAY
+40 ;MSC/IHS/MGH If there is a corresponding ICD0 code, save it for lookup later
+41 IF $DATA(^ICPT(CPTIEN,"ICD",0))
Begin DoDot:1
+42 SET SCODE=0
FOR
SET SCODE=$ORDER(^ICPT(CPTIEN,"ICD",SCODE))
IF SCODE=""!(SCODE="B")
QUIT
Begin DoDot:2
+43 SET ICDARRY(SCODE)=CODE_"^"_V2
End DoDot:2
End DoDot:1
+44 QUIT
+45 ; Build dental history
DENBLD NEW ADA
+1 DO INIT("DEN")
+2 SET REC=$GET(^AUPNVDEN(IEN,0))
+3 IF REC=""
QUIT
+4 SET ADA=$PIECE(^AUTTADA(+REC,0),U)
+5 IF 'ADA
QUIT
+6 SET CPTIEN=$ORDER(^ICPT("B",ADA,0))
+7 IF 'CPTIEN
QUIT
+8 SET CODE=$PIECE($GET(^ICPT(CPTIEN,0)),U)
+9 IF CODE=""
QUIT
+10 SET ITEMNAME=$PIECE($GET(^ICPT(CPTIEN,0)),U,2)
+11 SET VIEN=$PIECE(REC,U,3)
+12 IF VIEN=""
QUIT
+13 SET PRV=$PIECE($GET(^AUPNVDEN(IEN,12)),U,4)
+14 DO ARRAY
+15 QUIT
+16 ; Interface with V TRANSACTION CODE file
TRANBLD DO INIT("TC")
+1 SET REC=$GET(^AUPNVTC(IEN,0))
+2 IF REC=""
QUIT
+3 SET TRANIEN=$PIECE(REC,U)
+4 IF TRANIEN=""
QUIT
+5 SET CODE=$PIECE($GET(^BCMTCF(TRANIEN,0)),U)
+6 SET VIEN=$PIECE(REC,U,3)
+7 SET ITEMNAME=$PIECE($GET(^BCMTCF(TRANIEN,0)),U,7)
+8 SET MOD1=$PIECE(REC,U,8)
+9 SET PRV=$PIECE($GET(^AUPNVTC(IEN,12)),U,4)
+10 DO ARRAY
+11 QUIT
+12 ; Interface with V PROCEDURE file
PRCBLD(SRCH) NEW SKIP,X,Y,ICODE
+1 DO INIT("PRC")
+2 SET REC=$GET(^AUPNVPRC(IEN,0))
+3 IF REC=""
QUIT
+4 SET ICD0IEN=$PIECE(REC,U)
+5 IF ICD0IEN=""
QUIT
+6 SET VIEN=$PIECE(REC,U,3)
+7 SET V3=$PIECE($GET(^AUPNVSIT(VIEN,0)),U)
+8 SET DX=$PIECE(REC,U,5)
+9 SET PNAR=$PIECE(REC,U,4)
+10 SET PRV=$PIECE($GET(^AUPNVPRC(IEN,12)),U,4)
+11 ;IHS/MSC/MGH Changed the 2 to a 1 to return the proper field Patch 17
+12 IF $$AICD^BGOUTL2
SET CODE=$PIECE($$ICDOP^ICDEX(ICD0IEN,V3,"","I"),U,2)
+13 IF '$TEST
SET CODE=$PIECE($GET(^ICD0(ICD0IEN,0)),U)
+14 IF CODE=""
QUIT
+15 ; Do not include ICD procedures that correspond to CPT procedures
+16 SET (X,SKIP)=0
+17 ;IHS/MSC/MGH Use the saved array to check for matching codes and dates
+18 IF 'VISITIEN
Begin DoDot:1
+19 SET ICODE=0
FOR
SET ICODE=$ORDER(ICDARRY(ICODE))
IF ICODE=""
QUIT
Begin DoDot:2
+20 IF ICD0IEN=ICODE&($PIECE($GET(ICDARRY(ICODE)),U,2)=V3)
SET SKIP=1
QUIT
End DoDot:2
End DoDot:1
+21 IF '$TEST
Begin DoDot:1
+22 FOR
SET X=$ORDER(^ICPT("I",ICD0IEN,X))
IF 'X
QUIT
Begin DoDot:2
+23 SET Y=0
+24 FOR
SET Y=$ORDER(^AUPNVCPT("AD",VISITIEN,Y))
IF 'Y
QUIT
IF +^AUPNVCPT(Y,0)=X
SET SKIP=1
QUIT
End DoDot:2
IF SKIP
QUIT
End DoDot:1
+25 IF SKIP
QUIT
+26 IF TYP="SURGICAL"
Begin DoDot:1
+27 SET SKIP=1
+28 ;Patch 16 changed lookup
+29 IF SRCH
IF $$ICD^ATXAPI(ICD0IEN,$ORDER(^ATXAX("B","APCH MINOR SURGICAL PROCS",0)),0)
QUIT
+30 ;Q:CODE\1>85
+31 ;Q:CODE=69.7
+32 ;Q:CODE\1=23
+33 ;Q:CODE\1=24
+34 SET SKIP=0
End DoDot:1
IF SKIP
QUIT
+35 IF $$AICD^BGOUTL2
SET ITEMNAME=$PIECE($$ICDOP^ICDEX(ICD0IEN,V3,"","I"),U,5)
+36 IF '$TEST
SET ITEMNAME=$PIECE($$ICDOP^ICDCODE(ICD0IEN,V3),U,5)
+37 ;S ITEMNAME=$P($G(^ICD0(ICD0IEN,0)),U,4)
+38 DO ARRAY
+39 QUIT
INIT(X) SET (CPT,ITEMNAME,PNAR,DX,PRIM,MOD1,MOD2,VIEN,CPTIEN,QTY,PRV,TRANIEN,ICD0IEN)=""
SET VF=X
+1 QUIT
ARRAY NEW F,V,VDATE,FAC,FACNAM
+1 SET F=$PIECE($GET(^AUPNVSIT(VIEN,0)),U,6)
+2 SET FAC=$PIECE($GET(^AUTTLOC(+F,0)),U,10)
+3 SET FACNAM=$PIECE($GET(^AUTTLOC(+F,0)),U)
+4 SET FACNAM=$PIECE($GET(^DIC(4,+FACNAM,0)),U)
+5 IF $PIECE($GET(^AUPNVSIT(VIEN,21)),U)'=""
SET FACNAM=$PIECE(^(21),U)
+6 SET V=$PIECE($GET(^AUPNVSIT(VIEN,0)),U)
+7 IF V=""
QUIT
+8 SET VDATE=$$FMTDATE^BGOUTL(V)
+9 IF PNAR
SET PNAR=$PIECE($GET(^AUTNPOV(PNAR,0)),U)
+10 IF PNAR=""
SET PNAR=ITEMNAME
+11 ;S:DX DX=$P($G(^ICD9(DX,0)),U,3) ;DKA Patch 13
+12 IF DX
Begin DoDot:1
+13 IF $$AICD^BGOUTL2
SET DX=$PIECE($$ICDDX^ICDEX(DX,VDATE,"","I"),U,4)
+14 IF '$TEST
SET DX=$PIECE($$ICDDX^ICDCODE(DX,VDATE),U,4)
End DoDot:1
+15 IF PRV
SET PRV=$PIECE($GET(^VA(200,PRV,0)),U)
+16 IF MOD1
SET MOD1=MOD1_"~"_$PIECE($GET(@$$MODGBL@(MOD1,0)),U,2)
+17 IF MOD2
SET MOD2=MOD2_"~"_$PIECE($GET(@$$MODGBL@(MOD2,0)),U,2)
+18 SET CNT=CNT+1
+19 SET @RET@(CNT)=VDATE_U_FAC_U_FACNAM_U_CODE_U_ITEMNAME_U_PNAR_U_DX_U_PRIM_U_MOD1_U_MOD2_U_IEN_U_VIEN_U_CPTIEN_U_QTY_U_PRV_U_TRANIEN_U_ICD0IEN_U_$$ISLOCKED^BEHOENCX(VIEN)_U_VF
+20 QUIT
+21 ; Returns CPT modifier global reference
+22 ;IHS/MSC/MGH Changed for code set versioning
MODGBL() ;P6
QUIT $SELECT($$CSVACT^BGOUTL2():"^DIC(81.3)",$GET(DUZ("AG"))="I":"^AUTTCMOD",1:"^DIC(81.3)")
+1 ; Delete a V CPT, V Procedure, or V Transaction Code entry.
+2 ; INP = IEN ^ Type
DEL(RET,INP) ;EP
+1 NEW IEN,TYP,FNUM
+2 SET IEN=+INP
SET RET=""
+3 IF 'IEN
SET RET=$$ERR^BGOUTL(1008)
QUIT
+4 SET TYP=$PIECE(INP,U,2)
+5 IF TYP=""
SET TYP="CPT"
+6 IF TYP="CPT"
Begin DoDot:1
+7 NEW CPTIEN,ICD0IEN,VIEN,PRCIEN,X
+8 SET X=$GET(^AUPNVCPT(IEN,0))
SET CPTIEN=+X
SET VIEN=+$PIECE(X,U,3)
SET ICD0IEN=0
+9 FOR
SET ICD0IEN=$ORDER(^ICPT(CPTIEN,"ICD",ICD0IEN))
IF 'ICD0IEN
QUIT
Begin DoDot:2
+10 SET PRCIEN=0
+11 FOR
SET PRCIEN=$ORDER(^AUPNVPRC("AD",VIEN,PRCIEN))
IF 'PRCIEN
QUIT
Begin DoDot:3
+12 IF +$GET(^AUPNVPRC(PRCIEN,0))=ICD0IEN
DO DEL(.RET,PRCIEN_"^PRC")
End DoDot:3
IF RET<0
QUIT
End DoDot:2
End DoDot:1
IF RET<0
QUIT
+13 SET FNUM=+$PIECE($GET(@("^AUPNV"_TYP_"(0)")),U,2)
+14 IF 'FNUM
SET RET=$$ERR^BGOUTL(1072,TYP)
+15 IF '$TEST
DO VFDEL^BGOUTL2(.RET,FNUM,IEN)
+16 QUIT
+17 ; Set VCPT quantity
+18 ; INP = VCPT IEN ^ Quantity
SETQTY(RET,INP) ;EP
+1 DO SETVAL(.RET,+INP,$PIECE(INP,U,2),.16)
+2 QUIT
+3 ; Set VCPT diagnosis
+4 ; INP = VCPT IEN ^ Diagnosis IEN
SETDX(RET,INP) ;EP
+1 DO SETVAL(.RET,+INP,"`"_$PIECE(INP,U,2),.05)
+2 QUIT
+3 ; Set a value
SETVAL(RET,IEN,VAL,FLD) ;
+1 NEW FDA
+2 SET FDA($$FNUM,IEN_",",FLD)=VAL
+3 SET RET=$$UPDATE^BGOUTL(.FDA,"E")
+4 IF 'RET
DO VFEVT^BGOUTL2($$FNUM,IEN,1)
+5 QUIT
+6 ; Checks CPT code for validity
+7 ; CPTIEN = CPT IEN
+8 ; ACTDT = Active Date
+9 ; Returns null if OK, or -n^error text
CHKCPT(CPTIEN,ACTDT,IEN) ;EP
+1 NEW RET,X
+2 SET RET=""
SET IEN=$GET(IEN)
+3 SET ACTDT=$GET(ACTDT,DT)
+4 IF $$CSVACT^BGOUTL2("ICPTCOD")
Begin DoDot:1
+5 ;IHS/MSC/MGH Added for HOTFIX to make sure we have the IEN and not the code
+6 IF +IEN
SET CPTIEN=$$CODEN^ICPTCOD(CPTIEN)
+7 SET X=$$CPT^ICPTCOD(CPTIEN,ACTDT)
+8 IF X<0
SET RET=$$ERR^BGOUTL(1073)
+9 IF '$TEST
IF '$PIECE(X,U,7)
SET RET=$$ERR^BGOUTL(1074)
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 NEW DELDT
+12 SET X=$GET(^ICPT(CPTIEN,0))
+13 IF X=""
SET RET=$$ERR^BGOUTL(1073)
QUIT
+14 IF $PIECE(X,U,4)
SET RET=$$ERR^BGOUTL(1074)
QUIT
+15 SET DELDT=$PIECE(X,U,7)
+16 IF DELDT
Begin DoDot:2
+17 IF 'ACTDT
SET ACTDT=DT
+18 IF $$FMDIFF^XLFDT(ACTDT,DELDT)>-1
SET RET=$$ERR^BGOUTL(1075)
End DoDot:2
End DoDot:1
+19 QUIT RET
+20 ; Add/edit a VCPT entry
+21 ; INP = Visit IEN [1] ^ CPT IEN [2] ^ Patient IEN [3] ^ Event Date [4] ^ Quantity [5] ^ Diagnosis [6] ^
+22 ; Modifier #1 [7] ^ Provider IEN [8] ^ Principal [9] ^ V File IEN [10] ^ Narrative [11] ^ Modifier #2 [12] ^
+23 ; Location IEN [13] ^ Outside Location [14] ^ Historical [15] ^ ICD Procedure Flag [16] ^ No Dups [17]
+24 ; .RET = VCPT IEN or -n^error text if not successful
SET(RET,INP) ;EP
+1 NEW VIEN,X,APCDALVR,DFN,TYPE,VFIEN,QTY,DX,MOD1,PRV,PRIN,NARR,MOD2,EVNTDT,LOCIEN,OUTLOC,HIST
+2 NEW DELDT,ICD0FLG,NODUP,VCAT,FDA,FNUM,VFNEW,IEN,CHKDT,APCDOVR
+3 SET RET=""
SET FNUM=$$FNUM
+4 SET VIEN=+INP
+5 SET TYPE=$PIECE(INP,U,2)
+6 SET DFN=$PIECE(INP,U,3)
+7 SET EVNTDT=$$CVTDATE^BGOUTL($PIECE(INP,U,4))
+8 IF EVNTDT=""
SET EVNTDT=$PIECE($GET(^AUPNVSIT(VIEN,0)),U,1)
+9 IF EVNTDT=""
SET EVNTDT=$$NOW^XLFDT
+10 SET QTY=$PIECE(INP,U,5)
+11 SET DX=$PIECE(INP,U,6)
+12 SET MOD1=$PIECE(INP,U,7)
+13 SET PRV=$PIECE(INP,U,8)
+14 SET PRIN=$PIECE(INP,U,9)
+15 SET VFIEN=$PIECE(INP,U,10)
+16 SET VFNEW='VFIEN
+17 SET RET=$$FNDNARR^BGOUTL2($PIECE(INP,U,11))
+18 IF RET<0
QUIT
+19 SET NARR=$SELECT(RET:"`"_RET,1:"")
SET RET=""
+20 SET MOD2=$PIECE(INP,U,12)
+21 SET LOCIEN=$PIECE(INP,U,13)
+22 SET OUTLOC=$PIECE(INP,U,14)
+23 SET HIST=$PIECE(INP,U,15)
+24 ;IHS/MSC/MGH per Susan Richards this lookup is no longer supported
+25 ;S ICD0FLG=$P(INP,U,16)
+26 SET NODUP=$PIECE(INP,U,17)
+27 IF 'VIEN
IF 'HIST
SET RET=$$ERR^BGOUTL(1002)
QUIT
+28 SET VCAT=$PIECE($GET(^AUPNVSIT(VIEN,0)),U,7)
+29 IF VCAT="E"
SET HIST=1
+30 IF 'TYPE
SET TYPE=+$ORDER(^ICPT("B","00099",0))
+31 ;IHS/MSC/MGH Dealing with old data, setting to first date
+32 ;CHANGE DATE TO 2900101 PATCH 9
+33 IF EVNTDT<2890101
SET CHKDT=2890101
+34 IF '$TEST
SET CHKDT=EVNTDT
+35 SET RET=$$CHKCPT(TYPE,CHKDT)
+36 IF RET<0
QUIT
+37 IF HIST
Begin DoDot:1
+38 SET RET=$$MAKEHIST^BGOUTL(DFN,EVNTDT,$SELECT($LENGTH(OUTLOC):OUTLOC,1:LOCIEN),VIEN)
+39 IF RET>0
SET VIEN=RET
End DoDot:1
IF RET<0
QUIT
+40 SET RET=$$CHKVISIT^BGOUTL(VIEN,DFN)
+41 IF RET
QUIT
+42 IF 'VFIEN
Begin DoDot:1
+43 ;IHS/MSC/MGH auto store if old data, Patch 9
IF EVNTDT<DT
SET APCDOVR=1
+44 DO VFNEW^BGOUTL2(.RET,FNUM,TYPE,VIEN,$SELECT(NODUP:"CPT",1:""))
+45 IF RET>0
SET VFIEN=RET
SET RET=""
End DoDot:1
IF RET
QUIT
+46 IF PRIN="X"!(PRIN="")
Begin DoDot:1
+47 SET X=$$GETPRIN(VIEN)
+48 SET PRIN=$SELECT('X:"Y",X=VFIEN:"Y",1:"N")
End DoDot:1
+49 SET FDA=$NAME(FDA(FNUM,VFIEN_","))
+50 SET @FDA@(.01)="`"_TYPE
+51 SET @FDA@(.04)=NARR
+52 SET @FDA@(.05)=$SELECT(DX:"`"_DX,1:"@")
+53 SET @FDA@(.07)=PRIN
+54 ;P6
IF $GET(DUZ("AG"))="I"
Begin DoDot:1
+55 SET @FDA@(.08)=$SELECT(MOD1:"`"_MOD1,1:"@")
+56 SET @FDA@(.09)=$SELECT(MOD2:"`"_MOD2,1:"@")
End DoDot:1
+57 IF '$TEST
Begin DoDot:1
+58 ;IHS/MSC/MGH changes added patch 8
+59 IF MOD1
IF '$DATA(^AUPNVCPT(VFIEN,1,"B",MOD1))
Begin DoDot:2
+60 IF MOD1
SET FDA(9000010.181,"?+1,"_VFIEN_",",.01)="`"_MOD1
End DoDot:2
+61 IF MOD2
IF '$DATA(^AUPNVCPT(VFIEN,2,"B",MOD2))
Begin DoDot:2
+62 IF MOD2
SET FDA(9000010.181,"?+1,"_VFIEN_",",.01)="`"_MOD2
End DoDot:2
+63 SET IEN(2)=1
SET IEN(3)=2
End DoDot:1
+64 SET @FDA@(.16)=$SELECT(QTY>0:QTY,1:1)
+65 SET @FDA@(1201)="N"
+66 ;S @FDA@(1204)="`"_$S(PRV:PRV,1:DUZ) ; PATCH 5
+67 ;PATCH 5
SET @FDA@(1204)="`"_DUZ
+68 ;Patch 11 Set date entered
+69 IF VFNEW
Begin DoDot:1
+70 SET @FDA@(1216)="N"
+71 SET @FDA@(1217)="`"_DUZ
End DoDot:1
+72 ;Patch 11 Set last modified
+73 SET @FDA@(1218)="N"
+74 SET @FDA@(1219)="`"_DUZ
+75 SET RET=$$UPDATE^BGOUTL(.FDA,"E",.IEN)
+76 IF RET
IF VFNEW
IF $$DELETE^BGOUTL(FNUM,VFIEN)
+77 IF RET
QUIT
+78 IF PRIN="Y"
SET RET=$$SETPRIN(VIEN,VFIEN)
+79 ;MSC/IHS/MGH Call to create entry in procedure file is removed in patch 5
+80 ;I 'RET,ICD0FLG D
+81 ;.N VFIEN,PRCIEN,FNUM
+82 ;.S PRCIEN=$O(^ICPT(TYPE,"ICD",0))
+83 ;.Q:'PRCIEN
+84 ;.S FNUM=9000010.08,VFIEN=0
+85 ;.D VFNEW^BGOUTL2(.RET,FNUM,PRCIEN,VIEN)
+86 ;.S:RET>0 VFIEN=RET,RET=""
+87 ;.Q:RET
+88 ;.S FDA=$NA(FDA(FNUM,VFIEN_","))
+89 ;.S @FDA@(.04)=NARR
+90 ;.S @FDA@(1201)=$S(EVNTDT:EVNTDT,1:"N")
+91 ;.;S @FDA@(1204)="`"_$S(PRV:PRV,1:DUZ) ;PATCH 5
+92 ;.S @FDA@(1204)="`"_DUZ
+93 ;.S RET=$$UPDATE^BGOUTL(.FDA,"E")
+94 IF 'RET
DO VFEVT^BGOUTL2(FNUM,VFIEN,'VFNEW)
+95 IF 'RET
SET RET=VFIEN
+96 QUIT
+97 ; Return IEN of principal VCPT entry
GETPRIN(VIEN) ;
+1 NEW VCPT
+2 SET VCPT=0
+3 FOR
SET VCPT=$ORDER(^AUPNVCPT("AD",VIEN,VCPT))
IF 'VCPT
QUIT
IF $PIECE($GET(^AUPNVCPT(VCPT,0)),U,7)="Y"
QUIT
+4 QUIT VCPT
+5 ; Set principal flag for specified entry, clearing all others
SETPRIN(VIEN,VCPTIEN) ;
+1 NEW VCPT,FDA
+2 SET VCPT=0
+3 FOR
SET VCPT=$ORDER(^AUPNVCPT("AD",VIEN,VCPT))
IF 'VCPT
QUIT
Begin DoDot:1
+4 SET FDA($$FNUM,VCPT_",",.07)=$SELECT(VCPT=VCPTIEN:"Y",1:"N")
End DoDot:1
+5 QUIT $$UPDATE^BGOUTL(.FDA)
+6 ; Add CPT code
ADDCPT(CPT,ICD,VSIT,DFN,PRV) ;EP
+1 NEW FDA,IEN,RET
+2 SET FDA=$NAME(FDA($$FNUM,"+1,"))
+3 SET @FDA@(.01)=CPT
+4 SET @FDA@(.02)=DFN
+5 SET @FDA@(.03)=VSIT
+6 IF $GET(ICD)
SET @FDA@(.05)=ICD
+7 SET @FDA@(.16)=1
+8 SET @FDA@(1201)=$$NOW^XLFDT
+9 SET @FDA@(1204)=$SELECT(PRV:PRV,1:DUZ)
+10 SET RET=$$UPDATE^BGOUTL(.FDA,,.IEN)
+11 IF 'RET
DO VFEVT^BGOUTL2($$FNUM,IEN(1),0)
+12 QUIT RET
+13 ; Return V File #
FNUM() QUIT 9000010.18
