BMXRPC10 ; IHS/OIT/GIS - RPC CALL FOR EXTENDED BROKER FUNCTIONALITY ; 08 Jun 2010 8:47 AM
;;4.0;BMX;**1,4**;JUN 28, 2010;Build 4
;; LOGIN RPCS TO RETURN PATIENTS, VISITS AND FACILITIES. SUPPORTS MULTI-INDEX PATIENT LOOKUP (DOB, NAME, CHART#, ETC)
;
GETFCRS(BMXFACS,BMXDUZ) ; EP - Gets all facilities for a user - returns RECORDSET
;
;S BMXFACS="T00030FACILITY_NAME^T00030FACILITY_IEN^T00002MOST_RECENT_LOOKUP"_$C(30)
N BMXI
S BMXI=0,BMXFACS=$NA(^TMP("BMX FIND",$J)) K @BMXFACS
S ^TMP("BMX FIND",$J,0)="T00030FACILITY_NAME^T00030FACILITY_IEN^T00002MOST_RECENT_LOOKUP"_$C(30)
I $G(BMXDUZ)="" G XFRCS
N BMXFN,BMXN,BMXSUB,BMXRCNT,CREF,OREF,SITE,LAST,DFLT
S BMXDUZ=$TR(BMXDUZ,$C(13),"")
S BMXDUZ=$TR(BMXDUZ,$C(10),"")
S BMXDUZ=$TR(BMXDUZ,$C(9),"")
S BMXFN=0
S CREF=$NA(^VA(200,BMXDUZ,2))
I '$O(@CREF@(0)) D G XFRCS ; GIS/OIT JAN 22, 2010 ; Ensure at least one site returned
. S BMXFN=$P(^AUTTSITE(1,0),U,1)
. S SITE=$P($G(^DIC(4,BMXFN,0)),U,1)
. S DFLT=0
. S BMXI=BMXI+1
. S ^TMP("BMX FIND",$J,BMXI)=SITE_U_BMXFN_U_DFLT_$C(30)
. Q
S OREF="^VA(200,"_BMXDUZ_",2,"
S LAST=$G(^DISV(BMXDUZ,OREF))
I LAST="" D
. S BMXFN=0
. F Q:LAST S BMXFN=$O(VA(200,BMXDUZ,2,BMXFN)) Q:'BMXFN D I LAST Q
.. I $P($G(^VA(200,BMXDUZ,2,BMXFN,0)),U,2) S LAST=BMXFN
.. Q
. Q
I LAST="" S LAST=$O(^VA(200,BMXDUZ,2,0)) ; IF LAST UNDEFINED, DEFAULT TO 1 ENTRY FOR THAT USER IN THE DIVISION SUBFILE
I LAST="" S LAST=$P($G(^XTV(8989.3,1,"XUS")),U,17) ; IF LAST UNDEFINED, GET VALUE FROM KERNEL SYSTEM PARAMETERS FILE
S BMXFN=0,STG=""
F S BMXFN=$O(@CREF@(BMXFN)) Q:'BMXFN D
. S SITE=$P($G(^DIC(4,BMXFN,0)),U,1) I SITE="" Q
. S DFLT=(LAST=BMXFN)
. S BMXI=BMXI+1
. S ^TMP("BMX FIND",$J,BMXI)=SITE_U_BMXFN_U_DFLT_$C(30)
. Q
XFRCS S BMXI=BMXI+1
S ^TMP("BMX FIND",$J,BMXI)=$C(31)
Q
;
GETVIS(OUT,STG) ; EP - RETURN SPECIFIED # OF VALID VISITS FOR THE PATIENT
S OUT="T00010VISIT_IEN^T00030PATIENT_IEN^T00021TIMESTAMP^T00030VISIT_TYPE^T00030LOCATION^T00010SERVICE CATEGORY^T00030CLINIC^T00030PRIMARY_PROVIDER^T00030PRIMARY_POV"_$C(30)
I $L($G(STG))
E G VOUT
N X,Y,Z,%,HDR,LINE,DFN,MAX,IDT,VIEN,CNT,STOP,TS,VIEN,TYPE,LOC,SCAT,CLIN,PPRV,PPOV,BDT,VDT,DATA
S DFN=+STG I '$D(^DPT(DFN,0)) G VOUT
S MAX=$P(STG,"|",2) I 'MAX S MAX=9
I '$O(^AUPNVSIT("AA",+$G(DFN),0)) G VOUT
S IDT=0,CNT=0,STOP=0,DATA=""
S BDT=$$FMADD^XLFDT(DT,-2)
F Q:STOP S IDT=$O(^AUPNVSIT("AA",DFN,IDT)) Q:'IDT S VIEN=999999999999 F Q:STOP S VIEN=$O(^AUPNVSIT("AA",DFN,IDT,VIEN),-1) Q:'VIEN D Q
. S X=$G(^AUPNVSIT(VIEN,0)) I '$L(X) Q ; VISIT DATA MUST EXIST
. S VDT=+X I 'VDT Q
. I $P(X,U,11) Q ; MUST BE AN 'ACTIVE' VISIT - NOT 'DELETED'
. I $P(X,U,5)'=DFN Q ; INVALID PATIENT IEN
. I $P(X,U,3)="" Q ; VISIT MUST HAVE A TYPE
. I '$P(X,U,6) Q ; MUST HAVE A VALID ENCOUNTER LOCATION
. I $P(X,U,7)="" Q ; VISIT MUST HAVE A CATEGORY
. I $P(X,U,8)="" Q ; VISIT MUST HAVE A VALID CLINIC STOP
. I VDT<BDT,'$D(^AUPNVPOV("AD",VIEN)) Q ; MUST HAVE A POV ; PATCHED BY GIS 4/27/2009
. I VDT<BDT,'$D(^AUPNVPRV("AD",VIEN)) Q ; MUST HAVE A PROVIDER
. D VIS(VIEN,DFN,.DATA)
. S CNT=CNT+1
. I CNT=MAX S STOP=1
. Q
VOUT S OUT=OUT_$G(DATA)_$C(31)
Q
;
VIS(VIEN,DFN,DATA) ; EP - APPEND VISIT DATA STRING
I $G(VIEN),$G(DFN)
E Q
N TYPE,LOC,SCAT,CLIN,PPRV,PPOV,VDT,FIEN,IENS,FLD,TYPE
S FIEN=9000010,IENS=VIEN_","
S TS=$$GET1^DIQ(FIEN,IENS,.01) I TS="" Q
S TYPE=$$GET1^DIQ(FIEN,IENS,.03)
S LOC=$$GET1^DIQ(FIEN,IENS,.06)
S SCAT=$$GET1^DIQ(FIEN,IENS,.07)
S CLIN=$$GET1^DIQ(FIEN,IENS,.08)
S PPRV=$$PPRV(VIEN)
S PPOV=$$PPOV(VIEN)
S DATA=DATA_VIEN_U_DFN_U_TS_U_LOC_U_SCAT_U_CLIN_U_PPRV_U_PPOV_$C(30)
Q
;
PPRV(VIEN) ; EP - GIVEN A VISIT IEN, RETURN THE PRIMARY PROVIDER NAME
; CALLED BY THE BMX SCHEMA
I '$D(^AUPNVPRV("AD",+$G(VIEN))) Q ""
N NAME,PIEN,VPIEN,X,Y,Z,%
S VPIEN=0,PIEN=""
F S VPIEN=$O(^AUPNVPRV("AD",VIEN,VPIEN)) Q:'VPIEN D I PIEN Q
. S X=$G(^AUPNVPRV(VPIEN,0)) I X="" Q
. S TYPE=$P(X,U,4)
. I TYPE="P" S PIEN=+X
. Q
I 'PIEN S VPIEN=$O(^AUPNVPRV("AD",VIEN,0)) I VPIEN S PIEN=+$G(^AUPNVPRV(VPIEN,0))
I 'PIEN Q ""
S PIEN=$$PRV^VENPCCU(PIEN)
S NAME=$P($G(^VA(200,PIEN,0)),U)
Q NAME
;
PPOV(VIEN) ; EP - GIVEN A VISIT IEN, RETURN THE PRIMARY PURPOSE OF VISIT ICD CODE (NARRATIVE)
; CALLED BY BMX SCHEMA
I '$D(^AUPNVPOV("AD",+$G(VIEN))) Q ""
N TXT,IIEN,VPIEN,X,Y,Z,%,ICD,NIEN,DX,VDT
S VPIEN=0,IIEN=""
F S VPIEN=$O(^AUPNVPOV("AD",VIEN,VPIEN)) Q:'VPIEN D I IIEN Q
. S X=$G(^AUPNVPOV(VPIEN,0)) I X="" Q
. S TYPE=$P(X,U,12)
. I TYPE="P" S IIEN=+X
. Q
I 'IIEN S VPIEN=$O(^AUPNVPOV("AD",VIEN,0)) I VPIEN S IIEN=+$G(^AUPNVPOV(VPIEN,0))
I IIEN,VPIEN
E Q ""
;
;Pull visit date/time
S VDT=$$GET1^DIQ(9000010,VIEN_",",.01,"I")
;
;Pull appropriate ICD-9/ICD-10 code
;
;ICD-9 or ICD-10
I $$VERSION^XPDUTL("AICD")>3.51 D
. NEW STR
. ;
. ;First try to locate ICD-10
. I $$IMP^ICDEXA(30)'>VDT D Q:ICD]""
.. S STR=$$ICDDATA^ICDXCODE(30,IIEN,VDT,"I")
.. S ICD=$S($P(STR,"^")<0:"",1:$P(STR,"^",2))
. ;
. ;If not an ICD-10 code try ICD-9 (could be before date or a historical entry)
. I $G(ICD)="" D
.. S STR=$$ICDDATA^ICDXCODE(1,IIEN,VDT,"I")
.. S ICD=$S($P(STR,"^")<0:"",1:$P(STR,"^",2))
;
I '$L(ICD) Q ""
S TXT=$$GET1^DIQ(9000010.07,VPIEN_",",.04,"E")
I $L(TXT)>20 S TXT=$E(TXT,1,17)_"..."
S DX=ICD_" ("_TXT_")"
Q DX
;
GETPAT(BMXRET,BMXSTR) ; EP - -- return patient in ADO table
; S X="MERR^BMXGU",@^%ZOSF("TRAP") ; m error trap
N BMXI,BMXERR,BMXUIEN,P,X,Y,Z,%,%DT
S P="|"
K ^BMXTMP($J)
S BMXI=0
S BMXERR=""
S BMXRET="T00010IEN^T00030PATIENTNAME^T00015DOB^T00001SEX^T00007CHART^T00009SSN^T00010REG^T00030LASTUPDATE^T00030CLASSBEN^T00010AGE"_$C(30)
S BMXPAT=$P(BMXSTR,P,1)
S BMXMT=$P(BMXSTR,P,2)
; S BMXNPAT=$P(BMXSTR,P,4)
I BMXMT="ALL"!(BMXMT="") S BMXMT=9999999
S BMXMT=(BMXMT-1)
S BMXPIEN=""
S X=BMXPAT D ^%DT
S Y=Y\1
I $E(Y,4,5)="00" G GETADO
I $E(Y,6,7)="00" G GETADO
I Y?7N D G GETADO
. S BMXPAT=Y
. S BMXPATE=$$PATDOB(.BMXPIEN,BMXPAT)
S X=$TR($P(BMXPAT," "),",","")
I X?1.30U S BMXPATE=$$PATNAM(.BMXPIEN,BMXPAT,"") G GETADO
I BMXPAT?9N D G GETADO
. S BMXPIEN=$$PATSSN(BMXPAT)
I BMXPAT?1.6N D G GETADO
. S BMXPIEN=$$PATCHT(.BMXPIEN,BMXPAT)
GETADO I $G(BMXPIEN),'$G(BMXPATS) D PATADO(.BMXPIEN)
S BMXRET=BMXRET_$C(31)_$G(BMXERR)
K BMXPAT,BMXPIEN,BMXCNT,BMXDA,BMXIEN,BMXPATE,BMXNM,BMXDB,BMXSX,BMXCT,BMXSSN
K BMXPATS
Q
;
PATSSN(PAT) ;-- look up by ssn
S BMXPIEN=$O(^DPT("SSN",PAT,0))
S BMXPIEN(1)=BMXPIEN
Q $G(BMXPIEN)
;
PATCHT(BMXPIEN,HRN) ;-- lookup by chart
N BMXCNT,BMXMCNT
S BMXCNT=0,BMXPATE=0,BMXMCNT=0,BMXPIEN=""
S BMXIEN=0 F S BMXIEN=$O(^AUPNPAT("D",HRN,BMXIEN)) Q:'BMXIEN D I BMXPIEN Q
. I '$D(^AUPNPAT("D",HRN,BMXIEN,DUZ(2))) Q
. S %=$O(^AUPNPAT("D",HRN,BMXIEN)) I %,$D(^AUPNPAT("D",HRN,%,DUZ(2))) S BMXIEN=999999999 Q ; MORE THAN ONE PAT WITH THIS CHART NUMBER!
. S BMXPIEN=BMXIEN
. S BMXCNT=BMXCNT+1
. S:'$D(BMXPIEN(BMXCNT)) BMXPIEN(BMXCNT)=0
. S BMXPIEN(BMXCNT)=BMXPIEN
. Q
Q BMXPIEN
;
PATDOB(BMXPATE,PAT) ;-- lookup by DOB
N BMXCNT
S BMXCNT=0,BMXPATE=0
S BMXIEN=0
F S BMXIEN=$O(^DPT("ADOB",PAT,BMXIEN)) Q:'BMXIEN D
. S:'$D(BMXPATE(BMXCNT)) BMXPATE(BMXCNT)=0
. S BMXCNT=BMXCNT+1,BMXPATE=1
. S BMXPATE(BMXCNT)=BMXIEN
. Q
S BMXPATE=BMXCNT
Q $G(BMXPATE)
;
PATNAM(BMXPATE,PAT,NPAT) ;lookup by name
S BMXCNT=0,BMXPATE=0
N BMXLEN
S BMXLEN=$L(PAT)
S BMXNAM=PAT
S BMXNAM=$$BEGIN(PAT)
I $G(NPAT)]"" S BMXNAM=NPAT
F S BMXNAM=$O(^DPT("B",BMXNAM)) Q:BMXNAM=""!($E(BMXNAM,1,BMXLEN)'=PAT)!(BMXCNT>BMXMT) D
. S BMXIEN=0 F S BMXIEN=$O(^DPT("B",BMXNAM,BMXIEN)) Q:'BMXIEN D
.. Q:$O(^DPT("B",BMXNAM,BMXIEN,0)) ;cmi/maw 4/25/2005 don't get aliases
.. S BMXCNT=BMXCNT+1
.. S:'$D(BMXPATE(BMXCNT)) BMXPATE(BMXCNT)=0
.. S BMXPATE(BMXCNT)=BMXIEN
S BMXPATE=BMXCNT
Q $G(BMXPATE)
;
BEGIN(PT) ;-- get begin point
N BMXPDA,BMXPIEN,BMXPCNT
S BMXPCNT=0
S BMXPDA=PT
I $O(^DPT("B",BMXPDA,0)) D
. S BMXPDA=$O(^DPT("B",BMXPDA),-1)
F S BMXPDA=$O(^DPT("B",BMXPDA)) Q
I $G(BMXPDA)="" Q ""
Q $O(^DPT("B",BMXPDA),-1)
;
PATADO(PIEN) ;-- ado return
NEW BMXCNTR,BMXELG
I '$G(DUZ(2)) Q ; DIVISION
S BMXCNTR=0
S BMXDA=0 F S BMXDA=$O(PIEN(BMXDA)) Q:'BMXDA D
. NEW BMXAGE
. S BMXCNTR=BMXCNTR+1
. S BMXPI=$G(PIEN(BMXDA))
. I '$D(^AUPNPAT(BMXPI,41,DUZ(2),0)) Q ; PATIENT NOT REGISTERED IN THE CURRENT DIVISION
. S BMXNM=$P($G(^DPT(BMXPI,0)),U)
. S BMXDB=$$FMTE^XLFDT($P($G(^DPT(BMXPI,0)),U,3))
. S BMXSX=$P($G(^DPT(BMXPI,0)),U,2)
. S BMXCT=$$HRN^AUPNPAT(BMXPI,DUZ(2))
. S BMXSSN=$P($G(^DPT(BMXPI,0)),U,9)
. S BMXUPD=$P($G(^AUPNPAT(BMXPI,0)),U,3)
. S BMXELG=$$GET1^DIQ(9000001,BMXPI,1111) ;cmi/maw 5/17/2007 added class/ben for status bar
. S BMXAGE=$$AGE^AUPNPAT(BMXPI,DT)
. S BMXI=BMXI+1
. S BMXRET=BMXRET_BMXPI_U_BMXNM_U_BMXDB_U_BMXSX_U_BMXCT_U_BMXSSN_U_$G(BMXHD)_U_BMXUPD_U_BMXELG_U_BMXAGE_$C(30)
Q
;
BMXCCXT(RESULT,XOPTION) ;creates context for the passed in option
N XWB1,%,IEN,SIEN,OK,OPTION
S RESULT=0
S OPTION=$$DECRYP^XUSRB1(XOPTION) ;S:OPTION="" OPTION="\"
I $E(OPTION,1,3)="BMX" S RESULT=1 Q ; NO RESTRICTIONS FOR BMX CONTEXT FOR THIS PORT
K XQY0,XQY
I OPTION="" S XQY=0,XQY0="" Q ;delete context if "" passed in N PORT
S PORT=+$P($P,"|",3) I 'PORT Q
S IEN=$O(^BMXMON("B",PORT,0)) I 'IEN Q
I '$O(^BMXMON(IEN,1,0)) G BC1 ; NO RESTRICTIONS ON CONTEXT FOR THIS PORT
S OK=0,CIEN=0
F S CIEN=$O(^BMXMON(IEN,1,CIEN)) Q:'CIEN D I OK Q
. S %=$P($G(^BMXMON(IEN,1,CIEN,0)),U) I '% Q
. S %=$P($G(^DIC(19,%,0)),U) I %="" Q
. I %=OPTION S OK=1
. Q
I 'OK S (XWBSEC,RESULT)="The context '"_OPTION_"' is not registered with port "_PORT_"." Q
BC1 S XWB1=$$OPTLK^XQCS(OPTION)
I XWB1="" S (XWBSEC,RESULT)="The context '"_OPTION_"' does not exist on server." Q ;P10
S RESULT=$$CHK^XQCS(DUZ,XWB1)
;Access or programmer
BC2 I RESULT!$$KCHK^XUSRB("XUPROGMODE") S XQY0=OPTION,XQY=XWB1,RESULT=1 Q
S XWBSEC=RESULT
Q
;
CVC(OUT,IN) ; EP - RPC: BMX CVC ; CHECK VERIFY CODE (SEE CVC^XUSRB)
S OUT(0)=99,OUT(1)="INVALID PARAMETERS"
I $L(IN)
E Q
N AV,EAC,EOVC,ENVC,USER,AC,OVC,NVC,EVC,NVC,X,Y,Z,%,RET,U
S U="^",RET(0)="",RET(1)=""
S AV=$$DECRYP^XUSRB1(IN) I AV="" Q
S AC=$P(AV,";")
S X=$$EN^XUSHSH(AC)
S USER=$O(^VA(200,"A",X,0)) I 'USER Q
S @$C(68,85,90)=USER
S OVC=$P(AV,";",2) I OVC="" Q
S NVC=$P(AV,";",3) I NVC="" Q
S EOVC=$$ENCRYP^XUSRB1(OVC)
S ENVC=$$ENCRYP^XUSRB1(NVC)
D CVC^XUSRB(.RET,(ENVC_U_EOVC))
M OUT=RET
Q
;
TEST ; TEST CVC
N DUZ,IN
S IN=$$ENCRYP^XUSRB1("GREG4330;IRA-1727;IRA-1727")
D CVC^BMXRPC10(.OUT,IN) W !,$G(OUT(0))," - ",$G(OUT(1))
Q
;
MON ; EP - OPTION: BMX MONITOR VIEW
N X,Y,Z,%,PORT,ARR,STAT,DESC,IEN,CNT
W !!,"Checking BMX ports"
S PORT=0
F S PORT=$O(^BMXMON("B",PORT)) Q:'PORT D
. S IEN=$O(^BMXMON("B",PORT,0)) I 'IEN Q
. W "."
. I '$P($G(^BMXMON(IEN,0)),U,2) S STAT="NOT ENABLED"
. E D
.. S STAT="RUNNING"
.. I $$SEMAPHOR^BMXMON(PORT,"LOCK") S STAT="STOPPED" I $$SEMAPHOR^BMXMON(PORT,"UNLOCK")
.. Q
. S DESC=$G(^BMXMON(IEN,2))
. S ARR(PORT)=STAT_"|"_DESC
. Q
I '$D(ARR) W !,"No BMX ports have been registered in this namespace",!! Q
W !,"The following BMX ports have been registered in this namespace...",!
S PORT=0,CNT=0
F S PORT=$O(ARR(PORT)) Q:'PORT D
. S CNT=CNT+1
. I '(CNT#6) W "<Press ENTER to see more>" R %:$G(DTIME,60) W $C(13),?77,$C(13)
. S %=ARR(PORT)
. S STAT=$P(%,"|"),DESC=$P(%,"|",2)
. W !?2,"Port: ",PORT,?15,"Status: ",STAT,!?2,"Description: ",DESC
. W !
. Q
Q
;
BMXRPC10 ; IHS/OIT/GIS - RPC CALL FOR EXTENDED BROKER FUNCTIONALITY ; 08 Jun 2010 8:47 AM
+1 ;;4.0;BMX;**1,4**;JUN 28, 2010;Build 4
+2 ;; LOGIN RPCS TO RETURN PATIENTS, VISITS AND FACILITIES. SUPPORTS MULTI-INDEX PATIENT LOOKUP (DOB, NAME, CHART#, ETC)
+3 ;
GETFCRS(BMXFACS,BMXDUZ) ; EP - Gets all facilities for a user - returns RECORDSET
+1 ;
+2 ;S BMXFACS="T00030FACILITY_NAME^T00030FACILITY_IEN^T00002MOST_RECENT_LOOKUP"_$C(30)
+3 NEW BMXI
+4 SET BMXI=0
SET BMXFACS=$NAME(^TMP("BMX FIND",$JOB))
KILL @BMXFACS
+5 SET ^TMP("BMX FIND",$JOB,0)="T00030FACILITY_NAME^T00030FACILITY_IEN^T00002MOST_RECENT_LOOKUP"_$CHAR(30)
+6 IF $GET(BMXDUZ)=""
GOTO XFRCS
+7 NEW BMXFN,BMXN,BMXSUB,BMXRCNT,CREF,OREF,SITE,LAST,DFLT
+8 SET BMXDUZ=$TRANSLATE(BMXDUZ,$CHAR(13),"")
+9 SET BMXDUZ=$TRANSLATE(BMXDUZ,$CHAR(10),"")
+10 SET BMXDUZ=$TRANSLATE(BMXDUZ,$CHAR(9),"")
+11 SET BMXFN=0
+12 SET CREF=$NAME(^VA(200,BMXDUZ,2))
+13 ; GIS/OIT JAN 22, 2010 ; Ensure at least one site returned
IF '$ORDER(@CREF@(0))
Begin DoDot:1
+14 SET BMXFN=$PIECE(^AUTTSITE(1,0),U,1)
+15 SET SITE=$PIECE($GET(^DIC(4,BMXFN,0)),U,1)
+16 SET DFLT=0
+17 SET BMXI=BMXI+1
+18 SET ^TMP("BMX FIND",$JOB,BMXI)=SITE_U_BMXFN_U_DFLT_$CHAR(30)
+19 QUIT
End DoDot:1
GOTO XFRCS
+20 SET OREF="^VA(200,"_BMXDUZ_",2,"
+21 SET LAST=$GET(^DISV(BMXDUZ,OREF))
+22 IF LAST=""
Begin DoDot:1
+23 SET BMXFN=0
+24 FOR
IF LAST
QUIT
SET BMXFN=$ORDER(VA(200,BMXDUZ,2,BMXFN))
IF 'BMXFN
QUIT
Begin DoDot:2
+25 IF $PIECE($GET(^VA(200,BMXDUZ,2,BMXFN,0)),U,2)
SET LAST=BMXFN
+26 QUIT
End DoDot:2
IF LAST
QUIT
+27 QUIT
End DoDot:1
+28 ; IF LAST UNDEFINED, DEFAULT TO 1 ENTRY FOR THAT USER IN THE DIVISION SUBFILE
IF LAST=""
SET LAST=$ORDER(^VA(200,BMXDUZ,2,0))
+29 ; IF LAST UNDEFINED, GET VALUE FROM KERNEL SYSTEM PARAMETERS FILE
IF LAST=""
SET LAST=$PIECE($GET(^XTV(8989.3,1,"XUS")),U,17)
+30 SET BMXFN=0
SET STG=""
+31 FOR
SET BMXFN=$ORDER(@CREF@(BMXFN))
IF 'BMXFN
QUIT
Begin DoDot:1
+32 SET SITE=$PIECE($GET(^DIC(4,BMXFN,0)),U,1)
IF SITE=""
QUIT
+33 SET DFLT=(LAST=BMXFN)
+34 SET BMXI=BMXI+1
+35 SET ^TMP("BMX FIND",$JOB,BMXI)=SITE_U_BMXFN_U_DFLT_$CHAR(30)
+36 QUIT
End DoDot:1
XFRCS SET BMXI=BMXI+1
+1 SET ^TMP("BMX FIND",$JOB,BMXI)=$CHAR(31)
+2 QUIT
+3 ;
GETVIS(OUT,STG) ; EP - RETURN SPECIFIED # OF VALID VISITS FOR THE PATIENT
+1 SET OUT="T00010VISIT_IEN^T00030PATIENT_IEN^T00021TIMESTAMP^T00030VISIT_TYPE^T00030LOCATION^T00010SERVICE CATEGORY^T00030CLINIC^T00030PRIMARY_PROVIDER^T00030PRIMARY_POV"_$CHAR(30)
+2 IF $LENGTH($GET(STG))
+3 IF '$TEST
GOTO VOUT
+4 NEW X,Y,Z,%,HDR,LINE,DFN,MAX,IDT,VIEN,CNT,STOP,TS,VIEN,TYPE,LOC,SCAT,CLIN,PPRV,PPOV,BDT,VDT,DATA
+5 SET DFN=+STG
IF '$DATA(^DPT(DFN,0))
GOTO VOUT
+6 SET MAX=$PIECE(STG,"|",2)
IF 'MAX
SET MAX=9
+7 IF '$ORDER(^AUPNVSIT("AA",+$GET(DFN),0))
GOTO VOUT
+8 SET IDT=0
SET CNT=0
SET STOP=0
SET DATA=""
+9 SET BDT=$$FMADD^XLFDT(DT,-2)
+10 FOR
IF STOP
QUIT
SET IDT=$ORDER(^AUPNVSIT("AA",DFN,IDT))
IF 'IDT
QUIT
SET VIEN=999999999999
FOR
IF STOP
QUIT
SET VIEN=$ORDER(^AUPNVSIT("AA",DFN,IDT,VIEN),-1)
IF 'VIEN
QUIT
Begin DoDot:1
+11 ; VISIT DATA MUST EXIST
SET X=$GET(^AUPNVSIT(VIEN,0))
IF '$LENGTH(X)
QUIT
+12 SET VDT=+X
IF 'VDT
QUIT
+13 ; MUST BE AN 'ACTIVE' VISIT - NOT 'DELETED'
IF $PIECE(X,U,11)
QUIT
+14 ; INVALID PATIENT IEN
IF $PIECE(X,U,5)'=DFN
QUIT
+15 ; VISIT MUST HAVE A TYPE
IF $PIECE(X,U,3)=""
QUIT
+16 ; MUST HAVE A VALID ENCOUNTER LOCATION
IF '$PIECE(X,U,6)
QUIT
+17 ; VISIT MUST HAVE A CATEGORY
IF $PIECE(X,U,7)=""
QUIT
+18 ; VISIT MUST HAVE A VALID CLINIC STOP
IF $PIECE(X,U,8)=""
QUIT
+19 ; MUST HAVE A POV ; PATCHED BY GIS 4/27/2009
IF VDT<BDT
IF '$DATA(^AUPNVPOV("AD",VIEN))
QUIT
+20 ; MUST HAVE A PROVIDER
IF VDT<BDT
IF '$DATA(^AUPNVPRV("AD",VIEN))
QUIT
+21 DO VIS(VIEN,DFN,.DATA)
+22 SET CNT=CNT+1
+23 IF CNT=MAX
SET STOP=1
+24 QUIT
End DoDot:1
QUIT
VOUT SET OUT=OUT_$GET(DATA)_$CHAR(31)
+1 QUIT
+2 ;
VIS(VIEN,DFN,DATA) ; EP - APPEND VISIT DATA STRING
+1 IF $GET(VIEN)
IF $GET(DFN)
+2 IF '$TEST
QUIT
+3 NEW TYPE,LOC,SCAT,CLIN,PPRV,PPOV,VDT,FIEN,IENS,FLD,TYPE
+4 SET FIEN=9000010
SET IENS=VIEN_","
+5 SET TS=$$GET1^DIQ(FIEN,IENS,.01)
IF TS=""
QUIT
+6 SET TYPE=$$GET1^DIQ(FIEN,IENS,.03)
+7 SET LOC=$$GET1^DIQ(FIEN,IENS,.06)
+8 SET SCAT=$$GET1^DIQ(FIEN,IENS,.07)
+9 SET CLIN=$$GET1^DIQ(FIEN,IENS,.08)
+10 SET PPRV=$$PPRV(VIEN)
+11 SET PPOV=$$PPOV(VIEN)
+12 SET DATA=DATA_VIEN_U_DFN_U_TS_U_LOC_U_SCAT_U_CLIN_U_PPRV_U_PPOV_$CHAR(30)
+13 QUIT
+14 ;
PPRV(VIEN) ; EP - GIVEN A VISIT IEN, RETURN THE PRIMARY PROVIDER NAME
+1 ; CALLED BY THE BMX SCHEMA
+2 IF '$DATA(^AUPNVPRV("AD",+$GET(VIEN)))
QUIT ""
+3 NEW NAME,PIEN,VPIEN,X,Y,Z,%
+4 SET VPIEN=0
SET PIEN=""
+5 FOR
SET VPIEN=$ORDER(^AUPNVPRV("AD",VIEN,VPIEN))
IF 'VPIEN
QUIT
Begin DoDot:1
+6 SET X=$GET(^AUPNVPRV(VPIEN,0))
IF X=""
QUIT
+7 SET TYPE=$PIECE(X,U,4)
+8 IF TYPE="P"
SET PIEN=+X
+9 QUIT
End DoDot:1
IF PIEN
QUIT
+10 IF 'PIEN
SET VPIEN=$ORDER(^AUPNVPRV("AD",VIEN,0))
IF VPIEN
SET PIEN=+$GET(^AUPNVPRV(VPIEN,0))
+11 IF 'PIEN
QUIT ""
+12 SET PIEN=$$PRV^VENPCCU(PIEN)
+13 SET NAME=$PIECE($GET(^VA(200,PIEN,0)),U)
+14 QUIT NAME
+15 ;
PPOV(VIEN) ; EP - GIVEN A VISIT IEN, RETURN THE PRIMARY PURPOSE OF VISIT ICD CODE (NARRATIVE)
+1 ; CALLED BY BMX SCHEMA
+2 IF '$DATA(^AUPNVPOV("AD",+$GET(VIEN)))
QUIT ""
+3 NEW TXT,IIEN,VPIEN,X,Y,Z,%,ICD,NIEN,DX,VDT
+4 SET VPIEN=0
SET IIEN=""
+5 FOR
SET VPIEN=$ORDER(^AUPNVPOV("AD",VIEN,VPIEN))
IF 'VPIEN
QUIT
Begin DoDot:1
+6 SET X=$GET(^AUPNVPOV(VPIEN,0))
IF X=""
QUIT
+7 SET TYPE=$PIECE(X,U,12)
+8 IF TYPE="P"
SET IIEN=+X
+9 QUIT
End DoDot:1
IF IIEN
QUIT
+10 IF 'IIEN
SET VPIEN=$ORDER(^AUPNVPOV("AD",VIEN,0))
IF VPIEN
SET IIEN=+$GET(^AUPNVPOV(VPIEN,0))
+11 IF IIEN
IF VPIEN
+12 IF '$TEST
QUIT ""
+13 ;
+14 ;Pull visit date/time
+15 SET VDT=$$GET1^DIQ(9000010,VIEN_",",.01,"I")
+16 ;
+17 ;Pull appropriate ICD-9/ICD-10 code
+18 ;
+19 ;ICD-9 or ICD-10
+20 IF $$VERSION^XPDUTL("AICD")>3.51
Begin DoDot:1
+21 NEW STR
+22 ;
+23 ;First try to locate ICD-10
+24 IF $$IMP^ICDEXA(30)'>VDT
Begin DoDot:2
+25 SET STR=$$ICDDATA^ICDXCODE(30,IIEN,VDT,"I")
+26 SET ICD=$SELECT($PIECE(STR,"^")<0:"",1:$PIECE(STR,"^",2))
End DoDot:2
IF ICD]""
QUIT
+27 ;
+28 ;If not an ICD-10 code try ICD-9 (could be before date or a historical entry)
+29 IF $GET(ICD)=""
Begin DoDot:2
+30 SET STR=$$ICDDATA^ICDXCODE(1,IIEN,VDT,"I")
+31 SET ICD=$SELECT($PIECE(STR,"^")<0:"",1:$PIECE(STR,"^",2))
End DoDot:2
End DoDot:1
+32 ;
+33 IF '$LENGTH(ICD)
QUIT ""
+34 SET TXT=$$GET1^DIQ(9000010.07,VPIEN_",",.04,"E")
+35 IF $LENGTH(TXT)>20
SET TXT=$EXTRACT(TXT,1,17)_"..."
+36 SET DX=ICD_" ("_TXT_")"
+37 QUIT DX
+38 ;
GETPAT(BMXRET,BMXSTR) ; EP - -- return patient in ADO table
+1 ; S X="MERR^BMXGU",@^%ZOSF("TRAP") ; m error trap
+2 NEW BMXI,BMXERR,BMXUIEN,P,X,Y,Z,%,%DT
+3 SET P="|"
+4 KILL ^BMXTMP($JOB)
+5 SET BMXI=0
+6 SET BMXERR=""
+7 SET BMXRET="T00010IEN^T00030PATIENTNAME^T00015DOB^T00001SEX^T00007CHART^T00009SSN^T00010REG^T00030LASTUPDATE^T00030CLASSBEN^T00010AGE"_$CHAR(30)
+8 SET BMXPAT=$PIECE(BMXSTR,P,1)
+9 SET BMXMT=$PIECE(BMXSTR,P,2)
+10 ; S BMXNPAT=$P(BMXSTR,P,4)
+11 IF BMXMT="ALL"!(BMXMT="")
SET BMXMT=9999999
+12 SET BMXMT=(BMXMT-1)
+13 SET BMXPIEN=""
+14 SET X=BMXPAT
DO ^%DT
+15 SET Y=Y\1
+16 IF $EXTRACT(Y,4,5)="00"
GOTO GETADO
+17 IF $EXTRACT(Y,6,7)="00"
GOTO GETADO
+18 IF Y?7N
Begin DoDot:1
+19 SET BMXPAT=Y
+20 SET BMXPATE=$$PATDOB(.BMXPIEN,BMXPAT)
End DoDot:1
GOTO GETADO
+21 SET X=$TRANSLATE($PIECE(BMXPAT," "),",","")
+22 IF X?1.30U
SET BMXPATE=$$PATNAM(.BMXPIEN,BMXPAT,"")
GOTO GETADO
+23 IF BMXPAT?9N
Begin DoDot:1
+24 SET BMXPIEN=$$PATSSN(BMXPAT)
End DoDot:1
GOTO GETADO
+25 IF BMXPAT?1.6N
Begin DoDot:1
+26 SET BMXPIEN=$$PATCHT(.BMXPIEN,BMXPAT)
End DoDot:1
GOTO GETADO
GETADO IF $GET(BMXPIEN)
IF '$GET(BMXPATS)
DO PATADO(.BMXPIEN)
+1 SET BMXRET=BMXRET_$CHAR(31)_$GET(BMXERR)
+2 KILL BMXPAT,BMXPIEN,BMXCNT,BMXDA,BMXIEN,BMXPATE,BMXNM,BMXDB,BMXSX,BMXCT,BMXSSN
+3 KILL BMXPATS
+4 QUIT
+5 ;
PATSSN(PAT) ;-- look up by ssn
+1 SET BMXPIEN=$ORDER(^DPT("SSN",PAT,0))
+2 SET BMXPIEN(1)=BMXPIEN
+3 QUIT $GET(BMXPIEN)
+4 ;
PATCHT(BMXPIEN,HRN) ;-- lookup by chart
+1 NEW BMXCNT,BMXMCNT
+2 SET BMXCNT=0
SET BMXPATE=0
SET BMXMCNT=0
SET BMXPIEN=""
+3 SET BMXIEN=0
FOR
SET BMXIEN=$ORDER(^AUPNPAT("D",HRN,BMXIEN))
IF 'BMXIEN
QUIT
Begin DoDot:1
+4 IF '$DATA(^AUPNPAT("D",HRN,BMXIEN,DUZ(2)))
QUIT
+5 ; MORE THAN ONE PAT WITH THIS CHART NUMBER!
SET %=$ORDER(^AUPNPAT("D",HRN,BMXIEN))
IF %
IF $DATA(^AUPNPAT("D",HRN,%,DUZ(2)))
SET BMXIEN=999999999
QUIT
+6 SET BMXPIEN=BMXIEN
+7 SET BMXCNT=BMXCNT+1
+8 IF '$DATA(BMXPIEN(BMXCNT))
SET BMXPIEN(BMXCNT)=0
+9 SET BMXPIEN(BMXCNT)=BMXPIEN
+10 QUIT
End DoDot:1
IF BMXPIEN
QUIT
+11 QUIT BMXPIEN
+12 ;
PATDOB(BMXPATE,PAT) ;-- lookup by DOB
+1 NEW BMXCNT
+2 SET BMXCNT=0
SET BMXPATE=0
+3 SET BMXIEN=0
+4 FOR
SET BMXIEN=$ORDER(^DPT("ADOB",PAT,BMXIEN))
IF 'BMXIEN
QUIT
Begin DoDot:1
+5 IF '$DATA(BMXPATE(BMXCNT))
SET BMXPATE(BMXCNT)=0
+6 SET BMXCNT=BMXCNT+1
SET BMXPATE=1
+7 SET BMXPATE(BMXCNT)=BMXIEN
+8 QUIT
End DoDot:1
+9 SET BMXPATE=BMXCNT
+10 QUIT $GET(BMXPATE)
+11 ;
PATNAM(BMXPATE,PAT,NPAT) ;lookup by name
+1 SET BMXCNT=0
SET BMXPATE=0
+2 NEW BMXLEN
+3 SET BMXLEN=$LENGTH(PAT)
+4 SET BMXNAM=PAT
+5 SET BMXNAM=$$BEGIN(PAT)
+6 IF $GET(NPAT)]""
SET BMXNAM=NPAT
+7 FOR
SET BMXNAM=$ORDER(^DPT("B",BMXNAM))
IF BMXNAM=""!($EXTRACT(BMXNAM,1,BMXLEN)'=PAT)!(BMXCNT>BMXMT)
QUIT
Begin DoDot:1
+8 SET BMXIEN=0
FOR
SET BMXIEN=$ORDER(^DPT("B",BMXNAM,BMXIEN))
IF 'BMXIEN
QUIT
Begin DoDot:2
+9 ;cmi/maw 4/25/2005 don't get aliases
IF $ORDER(^DPT("B",BMXNAM,BMXIEN,0))
QUIT
+10 SET BMXCNT=BMXCNT+1
+11 IF '$DATA(BMXPATE(BMXCNT))
SET BMXPATE(BMXCNT)=0
+12 SET BMXPATE(BMXCNT)=BMXIEN
End DoDot:2
End DoDot:1
+13 SET BMXPATE=BMXCNT
+14 QUIT $GET(BMXPATE)
+15 ;
BEGIN(PT) ;-- get begin point
+1 NEW BMXPDA,BMXPIEN,BMXPCNT
+2 SET BMXPCNT=0
+3 SET BMXPDA=PT
+4 IF $ORDER(^DPT("B",BMXPDA,0))
Begin DoDot:1
+5 SET BMXPDA=$ORDER(^DPT("B",BMXPDA),-1)
End DoDot:1
+6 FOR
SET BMXPDA=$ORDER(^DPT("B",BMXPDA))
QUIT
+7 IF $GET(BMXPDA)=""
QUIT ""
+8 QUIT $ORDER(^DPT("B",BMXPDA),-1)
+9 ;
PATADO(PIEN) ;-- ado return
+1 NEW BMXCNTR,BMXELG
+2 ; DIVISION
IF '$GET(DUZ(2))
QUIT
+3 SET BMXCNTR=0
+4 SET BMXDA=0
FOR
SET BMXDA=$ORDER(PIEN(BMXDA))
IF 'BMXDA
QUIT
Begin DoDot:1
+5 NEW BMXAGE
+6 SET BMXCNTR=BMXCNTR+1
+7 SET BMXPI=$GET(PIEN(BMXDA))
+8 ; PATIENT NOT REGISTERED IN THE CURRENT DIVISION
IF '$DATA(^AUPNPAT(BMXPI,41,DUZ(2),0))
QUIT
+9 SET BMXNM=$PIECE($GET(^DPT(BMXPI,0)),U)
+10 SET BMXDB=$$FMTE^XLFDT($PIECE($GET(^DPT(BMXPI,0)),U,3))
+11 SET BMXSX=$PIECE($GET(^DPT(BMXPI,0)),U,2)
+12 SET BMXCT=$$HRN^AUPNPAT(BMXPI,DUZ(2))
+13 SET BMXSSN=$PIECE($GET(^DPT(BMXPI,0)),U,9)
+14 SET BMXUPD=$PIECE($GET(^AUPNPAT(BMXPI,0)),U,3)
+15 ;cmi/maw 5/17/2007 added class/ben for status bar
SET BMXELG=$$GET1^DIQ(9000001,BMXPI,1111)
+16 SET BMXAGE=$$AGE^AUPNPAT(BMXPI,DT)
+17 SET BMXI=BMXI+1
+18 SET BMXRET=BMXRET_BMXPI_U_BMXNM_U_BMXDB_U_BMXSX_U_BMXCT_U_BMXSSN_U_$GET(BMXHD)_U_BMXUPD_U_BMXELG_U_BMXAGE_$CHAR(30)
End DoDot:1
+19 QUIT
+20 ;
BMXCCXT(RESULT,XOPTION) ;creates context for the passed in option
+1 NEW XWB1,%,IEN,SIEN,OK,OPTION
+2 SET RESULT=0
+3 ;S:OPTION="" OPTION="\"
SET OPTION=$$DECRYP^XUSRB1(XOPTION)
+4 ; NO RESTRICTIONS FOR BMX CONTEXT FOR THIS PORT
IF $EXTRACT(OPTION,1,3)="BMX"
SET RESULT=1
QUIT
+5 KILL XQY0,XQY
+6 ;delete context if "" passed in N PORT
IF OPTION=""
SET XQY=0
SET XQY0=""
QUIT
+7 SET PORT=+$PIECE($PRINCIPAL,"|",3)
IF 'PORT
QUIT
+8 SET IEN=$ORDER(^BMXMON("B",PORT,0))
IF 'IEN
QUIT
+9 ; NO RESTRICTIONS ON CONTEXT FOR THIS PORT
IF '$ORDER(^BMXMON(IEN,1,0))
GOTO BC1
+10 SET OK=0
SET CIEN=0
+11 FOR
SET CIEN=$ORDER(^BMXMON(IEN,1,CIEN))
IF 'CIEN
QUIT
Begin DoDot:1
+12 SET %=$PIECE($GET(^BMXMON(IEN,1,CIEN,0)),U)
IF '%
QUIT
+13 SET %=$PIECE($GET(^DIC(19,%,0)),U)
IF %=""
QUIT
+14 IF %=OPTION
SET OK=1
+15 QUIT
End DoDot:1
IF OK
QUIT
+16 IF 'OK
SET (XWBSEC,RESULT)="The context '"_OPTION_"' is not registered with port "_PORT_"."
QUIT
BC1 SET XWB1=$$OPTLK^XQCS(OPTION)
+1 ;P10
IF XWB1=""
SET (XWBSEC,RESULT)="The context '"_OPTION_"' does not exist on server."
QUIT
+2 SET RESULT=$$CHK^XQCS(DUZ,XWB1)
+3 ;Access or programmer
BC2 IF RESULT!$$KCHK^XUSRB("XUPROGMODE")
SET XQY0=OPTION
SET XQY=XWB1
SET RESULT=1
QUIT
+1 SET XWBSEC=RESULT
+2 QUIT
+3 ;
CVC(OUT,IN) ; EP - RPC: BMX CVC ; CHECK VERIFY CODE (SEE CVC^XUSRB)
+1 SET OUT(0)=99
SET OUT(1)="INVALID PARAMETERS"
+2 IF $LENGTH(IN)
+3 IF '$TEST
QUIT
+4 NEW AV,EAC,EOVC,ENVC,USER,AC,OVC,NVC,EVC,NVC,X,Y,Z,%,RET,U
+5 SET U="^"
SET RET(0)=""
SET RET(1)=""
+6 SET AV=$$DECRYP^XUSRB1(IN)
IF AV=""
QUIT
+7 SET AC=$PIECE(AV,";")
+8 SET X=$$EN^XUSHSH(AC)
+9 SET USER=$ORDER(^VA(200,"A",X,0))
IF 'USER
QUIT
+10 SET @$CHAR(68,85,90)=USER
+11 SET OVC=$PIECE(AV,";",2)
IF OVC=""
QUIT
+12 SET NVC=$PIECE(AV,";",3)
IF NVC=""
QUIT
+13 SET EOVC=$$ENCRYP^XUSRB1(OVC)
+14 SET ENVC=$$ENCRYP^XUSRB1(NVC)
+15 DO CVC^XUSRB(.RET,(ENVC_U_EOVC))
+16 MERGE OUT=RET
+17 QUIT
+18 ;
TEST ; TEST CVC
+1 NEW DUZ,IN
+2 SET IN=$$ENCRYP^XUSRB1("GREG4330;IRA-1727;IRA-1727")
+3 DO CVC^BMXRPC10(.OUT,IN)
WRITE !,$GET(OUT(0))," - ",$GET(OUT(1))
+4 QUIT
+5 ;
MON ; EP - OPTION: BMX MONITOR VIEW
+1 NEW X,Y,Z,%,PORT,ARR,STAT,DESC,IEN,CNT
+2 WRITE !!,"Checking BMX ports"
+3 SET PORT=0
+4 FOR
SET PORT=$ORDER(^BMXMON("B",PORT))
IF 'PORT
QUIT
Begin DoDot:1
+5 SET IEN=$ORDER(^BMXMON("B",PORT,0))
IF 'IEN
QUIT
+6 WRITE "."
+7 IF '$PIECE($GET(^BMXMON(IEN,0)),U,2)
SET STAT="NOT ENABLED"
+8 IF '$TEST
Begin DoDot:2
+9 SET STAT="RUNNING"
+10 IF $$SEMAPHOR^BMXMON(PORT,"LOCK")
SET STAT="STOPPED"
IF $$SEMAPHOR^BMXMON(PORT,"UNLOCK")
+11 QUIT
End DoDot:2
+12 SET DESC=$GET(^BMXMON(IEN,2))
+13 SET ARR(PORT)=STAT_"|"_DESC
+14 QUIT
End DoDot:1
+15 IF '$DATA(ARR)
WRITE !,"No BMX ports have been registered in this namespace",!!
QUIT
+16 WRITE !,"The following BMX ports have been registered in this namespace...",!
+17 SET PORT=0
SET CNT=0
+18 FOR
SET PORT=$ORDER(ARR(PORT))
IF 'PORT
QUIT
Begin DoDot:1
+19 SET CNT=CNT+1
+20 IF '(CNT#6)
WRITE "<Press ENTER to see more>"
READ %:$GET(DTIME,60)
WRITE $CHAR(13),?77,$CHAR(13)
+21 SET %=ARR(PORT)
+22 SET STAT=$PIECE(%,"|")
SET DESC=$PIECE(%,"|",2)
+23 WRITE !?2,"Port: ",PORT,?15,"Status: ",STAT,!?2,"Description: ",DESC
+24 WRITE !
+25 QUIT
End DoDot:1
+26 QUIT
+27 ;
