BCDMFLDS.m

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)