BCDMFLDS ; ILC/ABQ/JLG - CDMP FIELD DEFINITIONS ;JUL 16, 2008 3:19 PM
;;1.0;IHS CHRONIC DISEASE MANAGEMENT;;JUN 29, 2010
;
TYPE() ;DIABETES TYPE FOR PATIENT
;Can use "AA" X-ref on V POV (AUPNVPOV) which is of the form ^AUPNVPOV("AA",DFN,inverse date,DA)
K BCDMTYPE
S DFN=INDA
S BCDMIVD=0
F S BCDMIVD=$O(^AUPNVPOV("AA",DFN,BCDMIVD)) Q:'BCDMIVD D Q:$D(BCDMTYPE)
.S DA=0
.F S DA=$O(^AUPNVPOV("AA",DFN,BCDMIVD,DA)) Q:'DA D Q:$D(BCDMTYPE)
..S BCDMICD=$P(^ICD9(+^AUPNVPOV(DA,0),0),U,1)
..Q:$P(BCDMICD,".",1)'=250
..S BCDMTYPE=$P(BCDMICD,".",2)#2
..I BCDMTYPE=0 S BCDMTYPE=2
S BCDMOUT="Diabetes type "
Q:'$D(BCDMTYPE) "N/A"
Q BCDMTYPE
;
ONSET() ;DIABETES ONSET DATE
N BCDMONDT
S BCDMONDT=""
S DFN=INDA
S DA=0
F S DA=$O(^AUPNPROB("AC",DFN,DA)) Q:'DA D Q:$D(BCDMONDT)
.S BCDMICD=$P(^ICD9(+^AUPNPROB(DA,0),0),U,1)
.Q:$P(BCDMICD,".",1)'=250
.S IENS=DA_","
.S BCDMONDT=$$GET1^DIQ(9000011,IENS,.13,"I")
.S BCDMONDT=$$CNVFMHL7(BCDMONDT)
Q BCDMONDT
;
ASPIRIN() ;On Aspirin?
K BCDMASP
S BCDMDFN=INDA
S PHARPAT=$O(^PS(55,"B",BCDMDFN,0))
I 'PHARPAT S BCDMASP="N" Q BCDMASP
S D1=0
F S D1=$O(^PS(55,PHARPAT,"P",D1)) Q:'D1 D
.S IENS=D1_","_PHARPAT_","
.D GETS^DIQ(55.03,IENS,".01;1","","BCDMASP")
.S IENS2=$G(BCDMASP(55.03,IENS,.01))_","
.Q:$G(IENS2)=""
.S STATUS=$$GET1^DIQ(52,IENS2,100)
.Q:STATUS'="ACTIVE"
.Q:BCDMASP(55.03,IENS,1)'["ASPIRIN"
.S BCDMASP="Y"
I '($D(BCDMASP)#2) S BCDMASP="N"
Q $G(BCDMASP)
;
NOTE() ;Patient note/returns area,location,tribal membership
S BCDMDFN=INDA
S IENS=BCDMDFN_","
S TRIBE=$$GET1^DIQ(9000001,IENS,1108)
S IENS=DUZ(2)_","
D GETS^DIQ(9999999.06,IENS,".01;.04","","BCDML")
Q $G(BCDML(9999999.06,IENS,.04))_","_$G(BCDML(9999999.06,IENS,.01))_","_TRIBE
;
VSITPROV() ;PROVIDER ID FOR ATTENDING OR PRIMARY PROVIDER OF VISIT
;The value of the visit ien will be provided by the program that calls GIS.
;It looks like that each call to the GIS API will have to have just one visit.
N PRVIEN,BCDMAT
S BCDMVIEN=INDA
S BCDMVPEN=0
F S BCDMVPEN=$O(^AUPNVPRV("AD",BCDMVIEN,BCDMVPEN)) Q:'BCDMVPEN D Q:BCDMAT
.S Y=^AUPNVPRV(BCDMVPEN,0)
.;Quit if provider not attending, operating, or primary. Only one should meet criterion
.S BCDMAT=$S($P(Y,U,5)="A":1,$P(Y,U,5)="O":1,$P(Y,U,4)="P":1,1:0) ;Need to check logic against real data
.Q:'BCDMAT
.S PRVIEN=$P(Y,U,1)
I '$D(PRVIEN) Q "^UNKNOWN"
S NAME=$P(^VA(200,PRVIEN,0),U,1)
S LNAME=$P(NAME,",",1)
S FNAME=$P($P(NAME,",",2)," ",1)
S MI=$P($P(NAME,",",2)," ",2)
S DEANUM=$P($G(^VA(200,PRVIEN,"P")),U,2)
Q DEANUM_U_LNAME_U_FNAME_U_MI
;
LABCODE ;Loinc code and lab name
;Field 1103 of the V LAB file is a pointer to file 61 the same as the site/specimen field of file 60.
;Should make it possible to track down the right loinc code.
;Will assume that if and only if there are results will the lab be transmitted. This should rule out panels.
;INA will have the ien of VISIT.
N CNTR,FILE,GLOB,GLB,BCDMIEN,IENS,LABIEN,LABNAME,REFRLO,REFRHI,SITEIEN,LOINC,VISIEN,CMMNT1
S CNTR=0
S VISIEN=INA("VISIEN")
F FILE=9000010.09,9000010.24,9000010.25 D
.S GLOB=$S(FILE=9000010.09:"^AUPNVLAB",FILE=9000010.24:"^AUPNVPTH",FILE=9000010.25:"^AUPNVMIC",1:"")
.S BCDMIEN=0
.F S BCDMIEN=$O(@GLOB@("AD",VISIEN,BCDMIEN)) Q:'BCDMIEN D
..S IENS=BCDMIEN_","
..S RESULT=$$GET1^DIQ(FILE,IENS,.04)
..I RESULT="" Q
..;Get 1 comment line
..S CMMNT1=""
..S D1=$O(@GLOB@(BCDMIEN,21,0))
..I D1 S CMMNT1=$G(@GLOB@(BCDMIEN,21,D1,0))
..S CNTR=CNTR+1
..S INDA("LAB1",CNTR)=""
..S INA("BCDMRSLT",CNTR)=RESULT_$S(CMMNT1]"":U_CMMNT1,1:"")
..S LABIEN=$$GET1^DIQ(FILE,IENS,.01,"I")
..S LABNAME=$$GET1^DIQ(FILE,IENS,.01,"E")
..S INA("BCDMUNIT",CNTR)=$$GET1^DIQ(FILE,IENS,1101,"E")
..S REFRLO=$$GET1^DIQ(FILE,IENS,1104,"E")
..S REFRHI=$$GET1^DIQ(FILE,IENS,1105,"E")
..S INA("BCDMREFR",CNTR)=REFRLO_" - "_REFRHI
..S INA("BCDMDATE",CNTR)=$$GET1^DIQ(FILE,IENS,1201,"E")
..I INA("BCDMDATE",CNTR)="" S INA("BCDMDATE",CNTR)=$$GET1^DIQ(9000010,VISIEN_",",.01,"E")
..S SITEIEN=$$GET1^DIQ(FILE,IENS,1103,"I")
..S INA("BCDMABFLG",CNTR)=$$GET1^DIQ(FILE,IENS,.05,"E")
..S IENS=SITEIEN_","_LABIEN_","
..S LOINC=$$GET1^DIQ(60.01,IENS,95.3)
..S INA("BCDMLABN",CNTR)=LOINC_U_LABNAME_U_"99IHS"
..S GLB=$P(GLOB,U,2)
..S INA("BCDMLABID",CNTR)=GLB_"-"_BCDMIEN
Q
;
ALIAS ;
N CNTR,BCDMIEN
S CNTR=0
S BCDMIEN=0
F S BCDMIEN=$O(^DPT(DFN,.01,BCDMIEN)) Q:'BCDMIEN D
.S INA("BCDMALIAS",1)=$G(INA("BCDMALIAS",1))_$$PN^INHUT($P(^DPT(DFN,.01,BCDMIEN,0),U),U)_"~"
Q
;
NAME(NAME) ; Add suffix to name
N SUFFIX,LNAME,MORE,FNAME,MNAME
S LNAME=$P(NAME,",",1)
S MORE=$P(NAME,",",2)
S FNAME=$P(MORE," ",1)
S MNAME=$P(MORE," ",2)
S SUFFIX=$P(NAME,",",3)
I SUFFIX="" S SUFFIX=$P(MORE," ",3)
S NAME=LNAME_U_FNAME_U_MNAME_U_SUFFIX
Q NAME
;
PATRXID(ID) ;Add Rx number to asufac Code
S RXNUM=$$RXNUM(INDA)
Q ID_RXNUM
;
RXNUM(IEN) ;
S RXNUM=$P($G(^AUPNVMED(IEN,11)),U,2)
I RXNUM]"" Q RXNUM
E D
.S RXIEN=$O(^PSRX("APCC",IEN,0))
.S RXNUM=$$GET1^DIQ(52,RXIEN_",",.01,"E")
I RXNUM]"" Q RXNUM
Q "UNK"
;
MED(MED) ;NDC CODE AND MEDICATION NAME
;<NDC code>^<drug name>^<99IHS>^^<non table drug name>^<99IHS>
I $P(^AUPNVMED(INDA,0),U,4)]"" D
.S NTDRUG=$P(^AUPNVMED(INDA,0),U,4)
.S MED=""
.S NDC=""
E D
.S NTDRUG=""
.S DRUGIEN=+^AUPNVMED(INDA,0)
.S IEN2=0
.F S IEN2=$O(^PSDRUG(DRUGIEN,1,IEN2)) Q:'IEN2 D Q:+NDC
..S NDC=$P(^PSDRUG(DRUGIEN,1,IEN2,0),U,2)
.I $G(NDC)="" S NDC=$P($G(^PSDRUG(DRUGIEN,2)),U,4)
Q NDC_U_MED_U_"99IHS"_U_U_NTDRUG_U_"99IHS"
;
REFILLS() ;NUMBER OF REFILLS REMAINING
N NUMREFL
D REFILVAR
I +$G(NUMREFL)=0 Q ""
;Assumption is made that only actual refills are stored in refills multiple below.
S D1=0
F S D1=$O(^PSRX(RXIEN,1,D1)) Q:'D1 D
.Q:'$D(^PSRX(RXIEN,1,D1,0))
.Q:$P(^PSRX(RXIEN,1,D1,0),U,14) ;Returned to stock
.Q:'$P(^PSRX(RXIEN,1,D1,0),U,19) ;Dispensed date
.S NUMREFL=NUMREFL-1
Q NUMREFL
;
REFILVAR ; Get refill variables
S IEN=INDA
S RXNUM=$$RXNUM(IEN)
Q:'RXNUM
S RXIEN=$O(^PSRX("B",RXNUM,""))
S NUMREFL=$P(^PSRX(RXIEN,0),U,9)
S INA("RXD3",INDA)=$$GET1^DIQ(52,RXIEN,1,"I") ;get rx date
Q
ISSUE(NDA) ;-- return issue date
N BCDMDT,BCDMRX
S BCDMRX=$O(^PSRX("APCC",NDA,0))
I '$G(BCDMRX) Q ""
S BCDMDT=$$GET1^DIQ(52,BCDMRX,1,"I")
Q $G(BCDMDT)
;
RXDATE() ;-- get the refill date
S IEN=INDA
S RXNUM=$$RXNUM(IEN)
I 'RXNUM Q ""
S RXIEN=$O(^PSRX("B",RXNUM,""))
S NUMREFL=$P(^PSRX(RXIEN,0),U,9)
Q $$CNVFMHL7($$GET1^DIQ(52,RXIEN,1)) ;get rx date
;
LASTRFDT(RXDT) ;Add last refill date to Rx Date
N NUMREFL
D REFILVAR
S RXDT=$$CNVFMHL7(RXDT)
I +$G(NUMREFL)=0 Q RXDT
S D1=0
F S D1=$O(^PSRX(RXIEN,1,D1)) Q:'D1 D
.Q:'$D(^PSRX(RXIEN,1,D1,0))
.Q:$P(^PSRX(RXIEN,1,D1,0),U,14) ;Returned to stock
.Q:'$P(^PSRX(RXIEN,1,D1,0),U,19) ;Dispensed date
.S TMP=$P(^PSRX(RXIEN,1,D1,0),U,19)
.S TMP=$$CNVFMHL7(TMP)
.I $E(TMP,1,8)'<$E(RXDT,1,8) Q
.S RFDISPDT=TMP
I $G(RFDISPDT) Q RXDT_U_RFDISPDT
E Q RXDT
;
CNVFMHL7(XDT) ;Convert fileman date/time to HL7 format
Q $$TIMEIO^INHUT10(XDT,"","","")
;
OBX5MED(IN) ;-- return the OBX -5 string
D REFILVAR
N QTY,PTID,SIG,REM
S QTY=$$GET1^DIQ(9000010.14,IN,.06)
S PTID=$G(INA("ASUFAC",IN))_IN
S SIG=$$GET1^DIQ(9000010.14,IN,.05)
S REM=$$REFILLS()
S STR="RXD"_U_QTY_U_SIG_U_REM_U_PTID
Q STR
;
PROCDATE ;Non lab CPT codes
;Go through (1)Visit, (2)Patient Ed, (2)V CPT, (2)V Radiology, (3)V Procedure, & (4)V Dental
N CNTR,IENS,EVM,CPTIEN,FILE,BCDMIEN,GLOB,FLD,DAT,VISIEN
S CNTR=0
S VISIEN=INA("VISIEN")
S IENS=VISIEN_","
D GETS^DIQ(9000010,IENS,".01;.17","EI","EVM","ERRMSG")
I EVM(9000010,IENS,.17,"I")]"" D
.S CNTR=CNTR+1
.S INDA("CPT1",CNTR)=""
.S INA("BCDMCPTDT",CNTR)=EVM(9000010,IENS,.01,"E")
.S CPTIEN=EVM(9000010,IENS,.17,"I")
.S FILE=9000010
.S BCDMIEN=VISIEN
.D CPTFILE
;Do the 3 that are alike together
F FILE=9000010.16,9000010.18,9000010.22 D
.S GLOB=$S(FILE=9000010.16:"^AUPNVPED",FILE=9000010.18:"^AUPNVCPT",FILE=9000010.22:"^AUPNVRAD",1:"")
.S BCDMIEN=0
.F S BCDMIEN=$O(@GLOB@("AD",VISIEN,BCDMIEN)) Q:'BCDMIEN D
..S IENS=BCDMIEN_","
..S CNTR=CNTR+1
..S INDA("CPT1",CNTR)=""
..S INA("BCDMCPTDT",CNTR)=$$GET1^DIQ(FILE,IENS,1201,"E")
..I INA("BCDMCPTDT",CNTR)="" S INA("BCDMCPTDT",CNTR)=$$GET1^DIQ(9000010,VISIEN_",",.01,"E")
..S FLD=$S(FILE=9000010.16:.09,FILE=9000010.18:.01,FILE=9000010.22:.019,1:0)
..S CPTIEN=$$GET1^DIQ(FILE,IENS,FLD,"I")
..D CPTFILE
S BCDMIEN=0
F S BCDMIEN=$O(^AUPNVPRC("AD",VISIEN,BCDMIEN)) Q:'BCDMIEN D
.S IENS=BCDMIEN_","
.D GETS^DIQ(9000010.08,IENS,".06:.16","IE","DAT","ERRMSG")
.Q:DAT(9000010.08,IENS,.16,"I")=""
.S CNTR=CNTR+1
.S INDA("CPT1",CNTR)=""
.S INA("BCDMCPTDT",CNTR)=DAT(9000010.08,IENS,.06,"E")
.S CPTIEN=DAT(9000010.08,IENS,.16,"I")
.S FILE=9000010.08
.D CPTFILE
S BCDMIEN=0
F S BCDMIEN=$O(^AUPNVDEN("AD",VISIEN,BCDMIEN)) Q:'BCDMIEN D
.S IENS=BCDMIEN_","
.D GETS^DIQ(9000010.05,IENS,".01;1201","IE","DAT","ERRMSG")
.S CNTR=CNTR+1
.S INDA("CPT1",CNTR)=""
.S INA("BCDMCPTDT",CNTR)=DAT(9000010.05,IENS,1201,"E")
.I INA("BCDMCPTDT",CNTR)="" S INA("BCDMCPTDT",CNTR)=$$GET1^DIQ(9000010,VISIEN_",",.01,"E")
.;Note: these are not CPT codes in this case. They are ADA codes
.S INA("BCDMCPT",CNTR)=DAT(9000010.05,IENS,.01,"E")
.S IENS2=DAT(9000010.05,IENS,.01,"I")_","
.S INA("BCDMCPTNM",CNTR)=$$GET1^DIQ(9999999.31,IENS2,.02,"E")
.S INA("BCDMCPTID",CNTR)=9000010.05_"-"_BCDMIEN
Q
;
CPTFILE ;
I 'CPTIEN D Q
.K INDA("CPT1",CNTR)
.S CNTR=CNTR-1
S INA("BCDMCPT",CNTR)=$$GET1^DIQ(81,CPTIEN_",",.01,"E")
S INA("BCDMCPTNM",CNTR)=$$GET1^DIQ(81,CPTIEN_",",2,"E")
S INA("BCDMCPTID",CNTR)=FILE_"-"_BCDMIEN
Q
;
VITLOBX(BCDMTYP,BCDMSEQ) ;Vitals Seg OBX
;BCDMTYP is the TYPE of measurement
;BCDMSEQ corresponds to the OBX-3, OBX-4, & OBX-5
N RESULT
S RESULT=""
S VIEN=INDA
S BCDMIEN=0
F S BCDMIEN=$O(^AUPNVMSR("AD",VIEN,BCDMIEN)) Q:'BCDMIEN D Q:RESULT]""
.S IENS=BCDMIEN_","
.I BCDMTYP'=$$GET1^DIQ(9000010.01,IENS,.01) S RESULT="" Q
.;.01 field of V Measurement is TYPE.
.I BCDMSEQ=4 S RESULT=BCDMTYP Q
.I BCDMSEQ=3 D Q
..S BCDMTIEN=$O(^AUTTMSR("B",BCDMTYP,0))
..S BCDMTNAM=$P(^AUTTMSR(BCDMTIEN,0),U,2)
..S RESULT=BCDMTYP_U_BCDMTNAM_U_"99IHS"
.I BCDMSEQ=5 S RESULT=$$GET1^DIQ(9000010.01,IENS,.04) ;value of the measurement
I RESULT="",BCDMSEQ=3 S RESULT=BCDMTYP_U_U_"99IHS"
Q RESULT
;
DX ;Diagnosis codes
N VISIEN,IENS,X,CNTR,IEN
S DFN=$O(INDA(2,0))
S CNTR=0
S VISIEN=INA("VISIEN")
S IENS=DFN_","
S X=$$GET1^DIQ(9000001,IENS,1114,"I")
I X]"" D
.D DX2
.S INA("BCDMDXDT",CNTR)=$$GET1^DIQ(2,DFN_",",.351,"I")
.S INA("BCDMDXID",CNTR)=9000001_"-"_DFN
S IEN=$O(^AUPNVINP("AD",VISIEN,0))
I IEN D
.S IENS=IEN_","
.S X=$$GET1^DIQ(9000010.02,IENS,.12,"I")
.Q:X=""
.D DX2
.S INA("BCDMDXDT",CNTR)=$$GET1^DIQ(9000010,VISIEN_",",.01,"I")
.S INA("BCDMDXID",CNTR)=9000010.02_"-"_IEN
S IEN=$O(^AUPNVCHS("AD",VISIEN,0))
I IEN D
.S IENS=IEN_","
.S X=$$GET1^DIQ(9000010.03,IENS,.09,"I")
.Q:X=""
.D DX2
.S INA("BCDMDXDT",CNTR)=$$GET1^DIQ(9000010,VISIEN_",",.01,"I")
.S INA("BCDMDXID",CNTR)=9000010.03_"-"_IEN
S BCDM=0
F S BCDM=$O(^AUPNVPOV("AD",VISIEN,BCDM)) Q:'BCDM D
.S IENS=BCDM_","
.S X=$$GET1^DIQ(9000010.07,IENS,.01,"I")
.Q:X=""
.D DX2
.S INA("BCDMDXDT",CNTR)=$$GET1^DIQ(9000010.07,BCDM_",",1201,"I")
.I INA("BCDMDXDT",CNTR)="" S INA("BCDMDXDT",CNTR)=$$GET1^DIQ(9000010,VISIEN_",",.01,"I")
.S INA("BCDMDXID",CNTR)=9000010.07_"-"_BCDM
Q
;
DX2 ;
S CNTR=CNTR+1
S IENS=X_","
D GETS^DIQ(80,IENS,".01:3","E","DXDATA","ERRMSG")
S INDA("DX1",CNTR)=""
S INA("BCDMDX",CNTR)=DXDATA(80,IENS,.01,"E")
S INA("BCDMDXNM",CNTR)=DXDATA(80,IENS,3,"E")
Q
;
ADMTYPE(INDA) ;
S IEN=$O(^AUPNVINP("AD",INDA,0))
S IENS=IEN_","
S X=$$GET1^DIQ(9000010.02,IENS,.07,"E")
Q X
;
SERVCAT(X) ;Transform serv cat into I and O
S X=$E(X,1)
Q $S((X="A")!(X="D"):"O",X="H":"I",1:X)
BCDMFLDS ; ILC/ABQ/JLG - CDMP FIELD DEFINITIONS ;JUL 16, 2008 3:19 PM
+1 ;;1.0;IHS CHRONIC DISEASE MANAGEMENT;;JUN 29, 2010
+2 ;
TYPE() ;DIABETES TYPE FOR PATIENT
+1 ;Can use "AA" X-ref on V POV (AUPNVPOV) which is of the form ^AUPNVPOV("AA",DFN,inverse date,DA)
+2 KILL BCDMTYPE
+3 SET DFN=INDA
+4 SET BCDMIVD=0
+5 FOR
SET BCDMIVD=$ORDER(^AUPNVPOV("AA",DFN,BCDMIVD))
IF 'BCDMIVD
QUIT
Begin DoDot:1
+6 SET DA=0
+7 FOR
SET DA=$ORDER(^AUPNVPOV("AA",DFN,BCDMIVD,DA))
IF 'DA
QUIT
Begin DoDot:2
+8 SET BCDMICD=$PIECE(^ICD9(+^AUPNVPOV(DA,0),0),U,1)
+9 IF $PIECE(BCDMICD,".",1)'=250
QUIT
+10 SET BCDMTYPE=$PIECE(BCDMICD,".",2)#2
+11 IF BCDMTYPE=0
SET BCDMTYPE=2
End DoDot:2
IF $DATA(BCDMTYPE)
QUIT
End DoDot:1
IF $DATA(BCDMTYPE)
QUIT
+12 SET BCDMOUT="Diabetes type "
+13 IF '$DATA(BCDMTYPE)
QUIT "N/A"
+14 QUIT BCDMTYPE
+15 ;
ONSET() ;DIABETES ONSET DATE
+1 NEW BCDMONDT
+2 SET BCDMONDT=""
+3 SET DFN=INDA
+4 SET DA=0
+5 FOR
SET DA=$ORDER(^AUPNPROB("AC",DFN,DA))
IF 'DA
QUIT
Begin DoDot:1
+6 SET BCDMICD=$PIECE(^ICD9(+^AUPNPROB(DA,0),0),U,1)
+7 IF $PIECE(BCDMICD,".",1)'=250
QUIT
+8 SET IENS=DA_","
+9 SET BCDMONDT=$$GET1^DIQ(9000011,IENS,.13,"I")
+10 SET BCDMONDT=$$CNVFMHL7(BCDMONDT)
End DoDot:1
IF $DATA(BCDMONDT)
QUIT
+11 QUIT BCDMONDT
+12 ;
ASPIRIN() ;On Aspirin?
+1 KILL BCDMASP
+2 SET BCDMDFN=INDA
+3 SET PHARPAT=$ORDER(^PS(55,"B",BCDMDFN,0))
+4 IF 'PHARPAT
SET BCDMASP="N"
QUIT BCDMASP
+5 SET D1=0
+6 FOR
SET D1=$ORDER(^PS(55,PHARPAT,"P",D1))
IF 'D1
QUIT
Begin DoDot:1
+7 SET IENS=D1_","_PHARPAT_","
+8 DO GETS^DIQ(55.03,IENS,".01;1","","BCDMASP")
+9 SET IENS2=$GET(BCDMASP(55.03,IENS,.01))_","
+10 IF $GET(IENS2)=""
QUIT
+11 SET STATUS=$$GET1^DIQ(52,IENS2,100)
+12 IF STATUS'="ACTIVE"
QUIT
+13 IF BCDMASP(55.03,IENS,1)'["ASPIRIN"
QUIT
+14 SET BCDMASP="Y"
End DoDot:1
+15 IF '($DATA(BCDMASP)#2)
SET BCDMASP="N"
+16 QUIT $GET(BCDMASP)
+17 ;
NOTE() ;Patient note/returns area,location,tribal membership
+1 SET BCDMDFN=INDA
+2 SET IENS=BCDMDFN_","
+3 SET TRIBE=$$GET1^DIQ(9000001,IENS,1108)
+4 SET IENS=DUZ(2)_","
+5 DO GETS^DIQ(9999999.06,IENS,".01;.04","","BCDML")
+6 QUIT $GET(BCDML(9999999.06,IENS,.04))_","_$GET(BCDML(9999999.06,IENS,.01))_","_TRIBE
+7 ;
VSITPROV() ;PROVIDER ID FOR ATTENDING OR PRIMARY PROVIDER OF VISIT
+1 ;The value of the visit ien will be provided by the program that calls GIS.
+2 ;It looks like that each call to the GIS API will have to have just one visit.
+3 NEW PRVIEN,BCDMAT
+4 SET BCDMVIEN=INDA
+5 SET BCDMVPEN=0
+6 FOR
SET BCDMVPEN=$ORDER(^AUPNVPRV("AD",BCDMVIEN,BCDMVPEN))
IF 'BCDMVPEN
QUIT
Begin DoDot:1
+7 SET Y=^AUPNVPRV(BCDMVPEN,0)
+8 ;Quit if provider not attending, operating, or primary. Only one should meet criterion
+9 ;Need to check logic against real data
SET BCDMAT=$SELECT($PIECE(Y,U,5)="A":1,$PIECE(Y,U,5)="O":1,$PIECE(Y,U,4)="P":1,1:0)
+10 IF 'BCDMAT
QUIT
+11 SET PRVIEN=$PIECE(Y,U,1)
End DoDot:1
IF BCDMAT
QUIT
+12 IF '$DATA(PRVIEN)
QUIT "^UNKNOWN"
+13 SET NAME=$PIECE(^VA(200,PRVIEN,0),U,1)
+14 SET LNAME=$PIECE(NAME,",",1)
+15 SET FNAME=$PIECE($PIECE(NAME,",",2)," ",1)
+16 SET MI=$PIECE($PIECE(NAME,",",2)," ",2)
+17 SET DEANUM=$PIECE($GET(^VA(200,PRVIEN,"P")),U,2)
+18 QUIT DEANUM_U_LNAME_U_FNAME_U_MI
+19 ;
LABCODE ;Loinc code and lab name
+1 ;Field 1103 of the V LAB file is a pointer to file 61 the same as the site/specimen field of file 60.
+2 ;Should make it possible to track down the right loinc code.
+3 ;Will assume that if and only if there are results will the lab be transmitted. This should rule out panels.
+4 ;INA will have the ien of VISIT.
+5 NEW CNTR,FILE,GLOB,GLB,BCDMIEN,IENS,LABIEN,LABNAME,REFRLO,REFRHI,SITEIEN,LOINC,VISIEN,CMMNT1
+6 SET CNTR=0
+7 SET VISIEN=INA("VISIEN")
+8 FOR FILE=9000010.09,9000010.24,9000010.25
Begin DoDot:1
+9 SET GLOB=$SELECT(FILE=9000010.09:"^AUPNVLAB",FILE=9000010.24:"^AUPNVPTH",FILE=9000010.25:"^AUPNVMIC",1:"")
+10 SET BCDMIEN=0
+11 FOR
SET BCDMIEN=$ORDER(@GLOB@("AD",VISIEN,BCDMIEN))
IF 'BCDMIEN
QUIT
Begin DoDot:2
+12 SET IENS=BCDMIEN_","
+13 SET RESULT=$$GET1^DIQ(FILE,IENS,.04)
+14 IF RESULT=""
QUIT
+15 ;Get 1 comment line
+16 SET CMMNT1=""
+17 SET D1=$ORDER(@GLOB@(BCDMIEN,21,0))
+18 IF D1
SET CMMNT1=$GET(@GLOB@(BCDMIEN,21,D1,0))
+19 SET CNTR=CNTR+1
+20 SET INDA("LAB1",CNTR)=""
+21 SET INA("BCDMRSLT",CNTR)=RESULT_$SELECT(CMMNT1]"":U_CMMNT1,1:"")
+22 SET LABIEN=$$GET1^DIQ(FILE,IENS,.01,"I")
+23 SET LABNAME=$$GET1^DIQ(FILE,IENS,.01,"E")
+24 SET INA("BCDMUNIT",CNTR)=$$GET1^DIQ(FILE,IENS,1101,"E")
+25 SET REFRLO=$$GET1^DIQ(FILE,IENS,1104,"E")
+26 SET REFRHI=$$GET1^DIQ(FILE,IENS,1105,"E")
+27 SET INA("BCDMREFR",CNTR)=REFRLO_" - "_REFRHI
+28 SET INA("BCDMDATE",CNTR)=$$GET1^DIQ(FILE,IENS,1201,"E")
+29 IF INA("BCDMDATE",CNTR)=""
SET INA("BCDMDATE",CNTR)=$$GET1^DIQ(9000010,VISIEN_",",.01,"E")
+30 SET SITEIEN=$$GET1^DIQ(FILE,IENS,1103,"I")
+31 SET INA("BCDMABFLG",CNTR)=$$GET1^DIQ(FILE,IENS,.05,"E")
+32 SET IENS=SITEIEN_","_LABIEN_","
+33 SET LOINC=$$GET1^DIQ(60.01,IENS,95.3)
+34 SET INA("BCDMLABN",CNTR)=LOINC_U_LABNAME_U_"99IHS"
+35 SET GLB=$PIECE(GLOB,U,2)
+36 SET INA("BCDMLABID",CNTR)=GLB_"-"_BCDMIEN
End DoDot:2
End DoDot:1
+37 QUIT
+38 ;
ALIAS ;
+1 NEW CNTR,BCDMIEN
+2 SET CNTR=0
+3 SET BCDMIEN=0
+4 FOR
SET BCDMIEN=$ORDER(^DPT(DFN,.01,BCDMIEN))
IF 'BCDMIEN
QUIT
Begin DoDot:1
+5 SET INA("BCDMALIAS",1)=$GET(INA("BCDMALIAS",1))_$$PN^INHUT($PIECE(^DPT(DFN,.01,BCDMIEN,0),U),U)_"~"
End DoDot:1
+6 QUIT
+7 ;
NAME(NAME) ; Add suffix to name
+1 NEW SUFFIX,LNAME,MORE,FNAME,MNAME
+2 SET LNAME=$PIECE(NAME,",",1)
+3 SET MORE=$PIECE(NAME,",",2)
+4 SET FNAME=$PIECE(MORE," ",1)
+5 SET MNAME=$PIECE(MORE," ",2)
+6 SET SUFFIX=$PIECE(NAME,",",3)
+7 IF SUFFIX=""
SET SUFFIX=$PIECE(MORE," ",3)
+8 SET NAME=LNAME_U_FNAME_U_MNAME_U_SUFFIX
+9 QUIT NAME
+10 ;
PATRXID(ID) ;Add Rx number to asufac Code
+1 SET RXNUM=$$RXNUM(INDA)
+2 QUIT ID_RXNUM
+3 ;
RXNUM(IEN) ;
+1 SET RXNUM=$PIECE($GET(^AUPNVMED(IEN,11)),U,2)
+2 IF RXNUM]""
QUIT RXNUM
+3 IF '$TEST
Begin DoDot:1
+4 SET RXIEN=$ORDER(^PSRX("APCC",IEN,0))
+5 SET RXNUM=$$GET1^DIQ(52,RXIEN_",",.01,"E")
End DoDot:1
+6 IF RXNUM]""
QUIT RXNUM
+7 QUIT "UNK"
+8 ;
MED(MED) ;NDC CODE AND MEDICATION NAME
+1 ;<NDC code>^<drug name>^<99IHS>^^<non table drug name>^<99IHS>
+2 IF $PIECE(^AUPNVMED(INDA,0),U,4)]""
Begin DoDot:1
+3 SET NTDRUG=$PIECE(^AUPNVMED(INDA,0),U,4)
+4 SET MED=""
+5 SET NDC=""
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 SET NTDRUG=""
+8 SET DRUGIEN=+^AUPNVMED(INDA,0)
+9 SET IEN2=0
+10 FOR
SET IEN2=$ORDER(^PSDRUG(DRUGIEN,1,IEN2))
IF 'IEN2
QUIT
Begin DoDot:2
+11 SET NDC=$PIECE(^PSDRUG(DRUGIEN,1,IEN2,0),U,2)
End DoDot:2
IF +NDC
QUIT
+12 IF $GET(NDC)=""
SET NDC=$PIECE($GET(^PSDRUG(DRUGIEN,2)),U,4)
End DoDot:1
+13 QUIT NDC_U_MED_U_"99IHS"_U_U_NTDRUG_U_"99IHS"
+14 ;
REFILLS() ;NUMBER OF REFILLS REMAINING
+1 NEW NUMREFL
+2 DO REFILVAR
+3 IF +$GET(NUMREFL)=0
QUIT ""
+4 ;Assumption is made that only actual refills are stored in refills multiple below.
+5 SET D1=0
+6 FOR
SET D1=$ORDER(^PSRX(RXIEN,1,D1))
IF 'D1
QUIT
Begin DoDot:1
+7 IF '$DATA(^PSRX(RXIEN,1,D1,0))
QUIT
+8 ;Returned to stock
IF $PIECE(^PSRX(RXIEN,1,D1,0),U,14)
QUIT
+9 ;Dispensed date
IF '$PIECE(^PSRX(RXIEN,1,D1,0),U,19)
QUIT
+10 SET NUMREFL=NUMREFL-1
End DoDot:1
+11 QUIT NUMREFL
+12 ;
REFILVAR ; Get refill variables
+1 SET IEN=INDA
+2 SET RXNUM=$$RXNUM(IEN)
+3 IF 'RXNUM
QUIT
+4 SET RXIEN=$ORDER(^PSRX("B",RXNUM,""))
+5 SET NUMREFL=$PIECE(^PSRX(RXIEN,0),U,9)
+6 ;get rx date
SET INA("RXD3",INDA)=$$GET1^DIQ(52,RXIEN,1,"I")
+7 QUIT
ISSUE(NDA) ;-- return issue date
+1 NEW BCDMDT,BCDMRX
+2 SET BCDMRX=$ORDER(^PSRX("APCC",NDA,0))
+3 IF '$GET(BCDMRX)
QUIT ""
+4 SET BCDMDT=$$GET1^DIQ(52,BCDMRX,1,"I")
+5 QUIT $GET(BCDMDT)
+6 ;
RXDATE() ;-- get the refill date
+1 SET IEN=INDA
+2 SET RXNUM=$$RXNUM(IEN)
+3 IF 'RXNUM
QUIT ""
+4 SET RXIEN=$ORDER(^PSRX("B",RXNUM,""))
+5 SET NUMREFL=$PIECE(^PSRX(RXIEN,0),U,9)
+6 ;get rx date
QUIT $$CNVFMHL7($$GET1^DIQ(52,RXIEN,1))
+7 ;
LASTRFDT(RXDT) ;Add last refill date to Rx Date
+1 NEW NUMREFL
+2 DO REFILVAR
+3 SET RXDT=$$CNVFMHL7(RXDT)
+4 IF +$GET(NUMREFL)=0
QUIT RXDT
+5 SET D1=0
+6 FOR
SET D1=$ORDER(^PSRX(RXIEN,1,D1))
IF 'D1
QUIT
Begin DoDot:1
+7 IF '$DATA(^PSRX(RXIEN,1,D1,0))
QUIT
+8 ;Returned to stock
IF $PIECE(^PSRX(RXIEN,1,D1,0),U,14)
QUIT
+9 ;Dispensed date
IF '$PIECE(^PSRX(RXIEN,1,D1,0),U,19)
QUIT
+10 SET TMP=$PIECE(^PSRX(RXIEN,1,D1,0),U,19)
+11 SET TMP=$$CNVFMHL7(TMP)
+12 IF $EXTRACT(TMP,1,8)'<$EXTRACT(RXDT,1,8)
QUIT
+13 SET RFDISPDT=TMP
End DoDot:1
+14 IF $GET(RFDISPDT)
QUIT RXDT_U_RFDISPDT
+15 IF '$TEST
QUIT RXDT
+16 ;
CNVFMHL7(XDT) ;Convert fileman date/time to HL7 format
+1 QUIT $$TIMEIO^INHUT10(XDT,"","","")
+2 ;
OBX5MED(IN) ;-- return the OBX -5 string
+1 DO REFILVAR
+2 NEW QTY,PTID,SIG,REM
+3 SET QTY=$$GET1^DIQ(9000010.14,IN,.06)
+4 SET PTID=$GET(INA("ASUFAC",IN))_IN
+5 SET SIG=$$GET1^DIQ(9000010.14,IN,.05)
+6 SET REM=$$REFILLS()
+7 SET STR="RXD"_U_QTY_U_SIG_U_REM_U_PTID
+8 QUIT STR
+9 ;
PROCDATE ;Non lab CPT codes
+1 ;Go through (1)Visit, (2)Patient Ed, (2)V CPT, (2)V Radiology, (3)V Procedure, & (4)V Dental
+2 NEW CNTR,IENS,EVM,CPTIEN,FILE,BCDMIEN,GLOB,FLD,DAT,VISIEN
+3 SET CNTR=0
+4 SET VISIEN=INA("VISIEN")
+5 SET IENS=VISIEN_","
+6 DO GETS^DIQ(9000010,IENS,".01;.17","EI","EVM","ERRMSG")
+7 IF EVM(9000010,IENS,.17,"I")]""
Begin DoDot:1
+8 SET CNTR=CNTR+1
+9 SET INDA("CPT1",CNTR)=""
+10 SET INA("BCDMCPTDT",CNTR)=EVM(9000010,IENS,.01,"E")
+11 SET CPTIEN=EVM(9000010,IENS,.17,"I")
+12 SET FILE=9000010
+13 SET BCDMIEN=VISIEN
+14 DO CPTFILE
End DoDot:1
+15 ;Do the 3 that are alike together
+16 FOR FILE=9000010.16,9000010.18,9000010.22
Begin DoDot:1
+17 SET GLOB=$SELECT(FILE=9000010.16:"^AUPNVPED",FILE=9000010.18:"^AUPNVCPT",FILE=9000010.22:"^AUPNVRAD",1:"")
+18 SET BCDMIEN=0
+19 FOR
SET BCDMIEN=$ORDER(@GLOB@("AD",VISIEN,BCDMIEN))
IF 'BCDMIEN
QUIT
Begin DoDot:2
+20 SET IENS=BCDMIEN_","
+21 SET CNTR=CNTR+1
+22 SET INDA("CPT1",CNTR)=""
+23 SET INA("BCDMCPTDT",CNTR)=$$GET1^DIQ(FILE,IENS,1201,"E")
+24 IF INA("BCDMCPTDT",CNTR)=""
SET INA("BCDMCPTDT",CNTR)=$$GET1^DIQ(9000010,VISIEN_",",.01,"E")
+25 SET FLD=$SELECT(FILE=9000010.16:.09,FILE=9000010.18:.01,FILE=9000010.22:.019,1:0)
+26 SET CPTIEN=$$GET1^DIQ(FILE,IENS,FLD,"I")
+27 DO CPTFILE
End DoDot:2
End DoDot:1
+28 SET BCDMIEN=0
+29 FOR
SET BCDMIEN=$ORDER(^AUPNVPRC("AD",VISIEN,BCDMIEN))
IF 'BCDMIEN
QUIT
Begin DoDot:1
+30 SET IENS=BCDMIEN_","
+31 DO GETS^DIQ(9000010.08,IENS,".06:.16","IE","DAT","ERRMSG")
+32 IF DAT(9000010.08,IENS,.16,"I")=""
QUIT
+33 SET CNTR=CNTR+1
+34 SET INDA("CPT1",CNTR)=""
+35 SET INA("BCDMCPTDT",CNTR)=DAT(9000010.08,IENS,.06,"E")
+36 SET CPTIEN=DAT(9000010.08,IENS,.16,"I")
+37 SET FILE=9000010.08
+38 DO CPTFILE
End DoDot:1
+39 SET BCDMIEN=0
+40 FOR
SET BCDMIEN=$ORDER(^AUPNVDEN("AD",VISIEN,BCDMIEN))
IF 'BCDMIEN
QUIT
Begin DoDot:1
+41 SET IENS=BCDMIEN_","
+42 DO GETS^DIQ(9000010.05,IENS,".01;1201","IE","DAT","ERRMSG")
+43 SET CNTR=CNTR+1
+44 SET INDA("CPT1",CNTR)=""
+45 SET INA("BCDMCPTDT",CNTR)=DAT(9000010.05,IENS,1201,"E")
+46 IF INA("BCDMCPTDT",CNTR)=""
SET INA("BCDMCPTDT",CNTR)=$$GET1^DIQ(9000010,VISIEN_",",.01,"E")
+47 ;Note: these are not CPT codes in this case. They are ADA codes
+48 SET INA("BCDMCPT",CNTR)=DAT(9000010.05,IENS,.01,"E")
+49 SET IENS2=DAT(9000010.05,IENS,.01,"I")_","
+50 SET INA("BCDMCPTNM",CNTR)=$$GET1^DIQ(9999999.31,IENS2,.02,"E")
+51 SET INA("BCDMCPTID",CNTR)=9000010.05_"-"_BCDMIEN
End DoDot:1
+52 QUIT
+53 ;
CPTFILE ;
+1 IF 'CPTIEN
Begin DoDot:1
+2 KILL INDA("CPT1",CNTR)
+3 SET CNTR=CNTR-1
End DoDot:1
QUIT
+4 SET INA("BCDMCPT",CNTR)=$$GET1^DIQ(81,CPTIEN_",",.01,"E")
+5 SET INA("BCDMCPTNM",CNTR)=$$GET1^DIQ(81,CPTIEN_",",2,"E")
+6 SET INA("BCDMCPTID",CNTR)=FILE_"-"_BCDMIEN
+7 QUIT
+8 ;
VITLOBX(BCDMTYP,BCDMSEQ) ;Vitals Seg OBX
+1 ;BCDMTYP is the TYPE of measurement
+2 ;BCDMSEQ corresponds to the OBX-3, OBX-4, & OBX-5
+3 NEW RESULT
+4 SET RESULT=""
+5 SET VIEN=INDA
+6 SET BCDMIEN=0
+7 FOR
SET BCDMIEN=$ORDER(^AUPNVMSR("AD",VIEN,BCDMIEN))
IF 'BCDMIEN
QUIT
Begin DoDot:1
+8 SET IENS=BCDMIEN_","
+9 IF BCDMTYP'=$$GET1^DIQ(9000010.01,IENS,.01)
SET RESULT=""
QUIT
+10 ;.01 field of V Measurement is TYPE.
+11 IF BCDMSEQ=4
SET RESULT=BCDMTYP
QUIT
+12 IF BCDMSEQ=3
Begin DoDot:2
+13 SET BCDMTIEN=$ORDER(^AUTTMSR("B",BCDMTYP,0))
+14 SET BCDMTNAM=$PIECE(^AUTTMSR(BCDMTIEN,0),U,2)
+15 SET RESULT=BCDMTYP_U_BCDMTNAM_U_"99IHS"
End DoDot:2
QUIT
+16 ;value of the measurement
IF BCDMSEQ=5
SET RESULT=$$GET1^DIQ(9000010.01,IENS,.04)
End DoDot:1
IF RESULT]""
QUIT
+17 IF RESULT=""
IF BCDMSEQ=3
SET RESULT=BCDMTYP_U_U_"99IHS"
+18 QUIT RESULT
+19 ;
DX ;Diagnosis codes
+1 NEW VISIEN,IENS,X,CNTR,IEN
+2 SET DFN=$ORDER(INDA(2,0))
+3 SET CNTR=0
+4 SET VISIEN=INA("VISIEN")
+5 SET IENS=DFN_","
+6 SET X=$$GET1^DIQ(9000001,IENS,1114,"I")
+7 IF X]""
Begin DoDot:1
+8 DO DX2
+9 SET INA("BCDMDXDT",CNTR)=$$GET1^DIQ(2,DFN_",",.351,"I")
+10 SET INA("BCDMDXID",CNTR)=9000001_"-"_DFN
End DoDot:1
+11 SET IEN=$ORDER(^AUPNVINP("AD",VISIEN,0))
+12 IF IEN
Begin DoDot:1
+13 SET IENS=IEN_","
+14 SET X=$$GET1^DIQ(9000010.02,IENS,.12,"I")
+15 IF X=""
QUIT
+16 DO DX2
+17 SET INA("BCDMDXDT",CNTR)=$$GET1^DIQ(9000010,VISIEN_",",.01,"I")
+18 SET INA("BCDMDXID",CNTR)=9000010.02_"-"_IEN
End DoDot:1
+19 SET IEN=$ORDER(^AUPNVCHS("AD",VISIEN,0))
+20 IF IEN
Begin DoDot:1
+21 SET IENS=IEN_","
+22 SET X=$$GET1^DIQ(9000010.03,IENS,.09,"I")
+23 IF X=""
QUIT
+24 DO DX2
+25 SET INA("BCDMDXDT",CNTR)=$$GET1^DIQ(9000010,VISIEN_",",.01,"I")
+26 SET INA("BCDMDXID",CNTR)=9000010.03_"-"_IEN
End DoDot:1
+27 SET BCDM=0
+28 FOR
SET BCDM=$ORDER(^AUPNVPOV("AD",VISIEN,BCDM))
IF 'BCDM
QUIT
Begin DoDot:1
+29 SET IENS=BCDM_","
+30 SET X=$$GET1^DIQ(9000010.07,IENS,.01,"I")
+31 IF X=""
QUIT
+32 DO DX2
+33 SET INA("BCDMDXDT",CNTR)=$$GET1^DIQ(9000010.07,BCDM_",",1201,"I")
+34 IF INA("BCDMDXDT",CNTR)=""
SET INA("BCDMDXDT",CNTR)=$$GET1^DIQ(9000010,VISIEN_",",.01,"I")
+35 SET INA("BCDMDXID",CNTR)=9000010.07_"-"_BCDM
End DoDot:1
+36 QUIT
+37 ;
DX2 ;
+1 SET CNTR=CNTR+1
+2 SET IENS=X_","
+3 DO GETS^DIQ(80,IENS,".01:3","E","DXDATA","ERRMSG")
+4 SET INDA("DX1",CNTR)=""
+5 SET INA("BCDMDX",CNTR)=DXDATA(80,IENS,.01,"E")
+6 SET INA("BCDMDXNM",CNTR)=DXDATA(80,IENS,3,"E")
+7 QUIT
+8 ;
ADMTYPE(INDA) ;
+1 SET IEN=$ORDER(^AUPNVINP("AD",INDA,0))
+2 SET IENS=IEN_","
+3 SET X=$$GET1^DIQ(9000010.02,IENS,.07,"E")
+4 QUIT X
+5 ;
SERVCAT(X) ;Transform serv cat into I and O
+1 SET X=$EXTRACT(X,1)
+2 QUIT $SELECT((X="A")!(X="D"):"O",X="H":"I",1:X)
