Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADE1.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADE1.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADE1.m (revision 1147) @@ -0,0 +1,83 @@ +BMXADE1 ; IHS/OIT/HMW - BMXNet ADO.NET PROVIDER ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; + ;Dental Excel report demo + ; +BMXADE(BMXGBL,BMXBEG,BMXEND) ;EP + ;Returns recordset containing services and minutes by reporting facility, patient's community and service unit + ; + N BMXBEGDT,BMXENDDT,BMXTMP,BMXDT,BMXRD,BMXIEN,BMXNOD,BMXPAT,BMXCOM,BMXFAC,BMXSU,BMXCOMP,BMXSUP,BMXFACP,BMXSVC,BMXMIN,BMXFEE + S U="^",BMXRD=$C(30) + K ^BMXTEMP($J),^BMXTMP($J) + S BMXGBL="^BMXTEMP("_$J_")" + S ^BMXTEMP($J,0)="T00030FACILITY^T00030PT_COMMUNITY^T00030PT_SERVICE_UNIT^I00030SERVICES^I00030MINUTES^I00030FEE"_BMXRD + S X=BMXBEG,%DT="P" D ^%DT S BMXBEGDT=Y + S X=BMXEND,%DT="P" D ^%DT S BMXENDDT=Y + I BMXENDDTBMXENDDT D + . S BMXIEN=0 F S BMXIEN=$O(^ADEPCD("AC",BMXDT,BMXIEN)) Q:'+BMXIEN D + . . Q:'$D(^ADEPCD(BMXIEN,0)) + . . S BMXNOD=^ADEPCD(BMXIEN,0) + . . S BMXPAT=$P(BMXNOD,U) + . . S BMXFACP=+$P(BMXNOD,U,3) + . . S BMXCOMP=$$GETCOMP(BMXPAT) + . . D CALCMIN(BMXIEN,.BMXSVC,.BMXMIN,.BMXFEE) + . . Q:BMXSVC=0 + . . S:'$D(^BMXTMP($J,BMXFACP,BMXCOMP)) ^BMXTMP($J,BMXFACP,BMXCOMP)="0^0^0" + . . S $P(^BMXTMP($J,BMXFACP,BMXCOMP),U)=$P(^(BMXCOMP),U)+BMXSVC + . . S $P(^BMXTMP($J,BMXFACP,BMXCOMP),U,2)=$P(^(BMXCOMP),U,2)+BMXMIN + . . S $P(^BMXTMP($J,BMXFACP,BMXCOMP),U,3)=$P(^(BMXCOMP),U,3)+BMXFEE + . . Q + . Q + ; + ;Traverse ^BMXTMP and fill in ^BMXTEMP + S BMXI=0 + S BMXFACP=-1 F S BMXFACP=$O(^BMXTMP($J,BMXFACP)) Q:BMXFACP="" D + . I BMXFACP=0 S BMXFAC="UNKNOWN" + . E S BMXFAC=$P($G(^DIC(4,BMXFACP,0)),U) S:BMXFAC="" BMXFAC="UNKNOWN" + . S BMXCOMP=-1 F S BMXCOMP=$O(^BMXTMP($J,BMXFACP,BMXCOMP)) Q:BMXCOMP="" D + . . I BMXCOMP=0 S BMXCOM="UNKNOWN" + . . E S BMXCOM=$P($G(^AUTTCOM(BMXCOMP,0)),U) S:BMXCOM="" BMXCOM="UNKNOWN" + . . S BMXSU=+$P($G(^AUTTCOM(BMXCOMP,0)),U,5) + . . I BMXSU=0 S BMXSU="UNKNOWN" + . . E S BMXSU=$P($G(^AUTTSU(BMXSU,0)),U) + . . S BMXI=BMXI+1 + . . S BMXSVC=$P(^BMXTMP($J,BMXFACP,BMXCOMP),U) + . . S BMXMIN=$P(^BMXTMP($J,BMXFACP,BMXCOMP),U,2) + . . S BMXFEE=$P(^BMXTMP($J,BMXFACP,BMXCOMP),U,3) + . . S ^BMXTEMP($J,BMXI)=BMXFAC_U_BMXCOM_U_BMXSU_U_BMXSVC_U_BMXMIN_U_BMXFEE_BMXRD + . . Q + . Q + S BMXI=BMXI+1 + S ^BMXTEMP($J,BMXI)=$C(31) + Q + ; +GETCOMP(BMXPAT) ; + ;Returns Patient Community Pointer + I '$D(^AUPNPAT(BMXPAT,11)) Q 0 + Q +$P(^AUPNPAT(BMXPAT,11),U,17) + ; +CALCMIN(BMXIEN,BMXSVC,BMXMIN,BMXFEE) ; + ;Returns count of lvl 1 - 6 services and minutes for entry BMXIEN + ;Uses ANMC rogue FEE field in AUTTADA to calculate FEE data + N BMXA,BMXCOD,BMXALVL + S BMXSVC=0,BMXMIN=0,BMXFEE=0 + Q:'$D(^ADEPCD(BMXIEN,"ADA")) + S BMXA=0 F S BMXA=$O(^ADEPCD(BMXIEN,"ADA",BMXA)) Q:'+BMXA D + . S BMXCOD=+^ADEPCD(BMXIEN,"ADA",BMXA,0) + . Q:'$D(^AUTTADA(BMXCOD,0)) + . S BMXANOD=^AUTTADA(BMXCOD,0) + . S BMXALVL=$P(BMXANOD,U,5) + . Q:BMXALVL=0 + . Q:BMXALVL>6 + . S BMXSVC=BMXSVC+1 + . S BMXMIN=BMXMIN+$P(BMXANOD,U,4) + . S BMXFEE=BMXFEE+$P(BMXANOD,U,12) + Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADE2.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADE2.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADE2.m (revision 1147) @@ -0,0 +1,90 @@ +BMXADE2 ; IHS/OIT/HMW - BMXNet ADO.NET PROVIDER ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; + ;Dental Excel report demo + ; +BMXADE(BMXGBL,BMXBEG,BMXEND) ;EP + ;Returns recordset containing services and minutes by reporting facility, Provider, and ADA Code + ; + N BMXBEGDT,BMXENDDT,BMXTMP,BMXDT,BMXRD,BMXIEN,BMXNOD,BMXCOM,BMXFAC,BMXSU,BMXCOMP,BMXSUP,BMXFACP,BMXSVC,BMXMIN,BMXLVL,BMXFEE + S U="^",BMXRD=$C(30) + K ^BMXTEMP($J),^BMXTMP($J) + S BMXGBL="^BMXTEMP("_$J_")" + S ^BMXTEMP($J,0)="T00030FACILITY^T00030PROVIDER^T00030ADA_CODE^T00030LEVEL^I00030SERVICES^I00030MINUTES^I00030FEE"_BMXRD + S X=BMXBEG,%DT="P" D ^%DT S BMXBEGDT=Y + S X=BMXEND,%DT="P" D ^%DT S BMXENDDT=Y + I BMXENDDTBMXENDDT D + . S BMXIEN=0 F S BMXIEN=$O(^ADEPCD("AC",BMXDT,BMXIEN)) Q:'+BMXIEN D + . . Q:'$D(^ADEPCD(BMXIEN,0)) + . . S BMXNOD=^ADEPCD(BMXIEN,0) + . . S BMXFACP=+$P(BMXNOD,U,3) + . . S BMXPRVP=+$P(BMXNOD,U,4) + . . S BMXCODP=0 F S BMXCODP=$O(^ADEPCD(BMXIEN,"ADA","B",BMXCODP)) Q:'+BMXCODP D + . . . D CALCMIN(BMXCODP,.BMXMIN) + . . . D CALCFEE(BMXCODP,.BMXFEE) + . . . S BMXCODPS=0,BMXSVC=0 F S BMXCODPS=$O(^ADEPCD(BMXIEN,"ADA","B",BMXCODP,BMXCODPS)) Q:'+BMXCODPS D + . . . . S BMXSVC=BMXSVC+1 + . . . S:'$D(^BMXTMP($J,BMXFACP,BMXPRVP,BMXCODP)) ^BMXTMP($J,BMXFACP,BMXPRVP,BMXCODP)="0^0" + . . . S $P(^BMXTMP($J,BMXFACP,BMXPRVP,BMXCODP),U)=$P(^(BMXCODP),U)+BMXSVC + . . . S $P(^BMXTMP($J,BMXFACP,BMXPRVP,BMXCODP),U,2)=$P(^(BMXCODP),U,2)+(BMXSVC*BMXMIN) + . . . S $P(^BMXTMP($J,BMXFACP,BMXPRVP,BMXCODP),U,3)=$P(^(BMXCODP),U,3)+(BMXSVC*BMXFEE) + . . . Q + . . Q + . Q + ; + ;Traverse ^BMXTMP and fill in ^BMXTEMP + S BMXI=0 + S BMXFACP=-1 F S BMXFACP=$O(^BMXTMP($J,BMXFACP)) Q:BMXFACP="" D + . I BMXFACP=0 S BMXFAC="UNKNOWN" + . E S BMXFAC=$P($G(^DIC(4,BMXFACP,0)),U) S:BMXFAC="" BMXFAC="UNKNOWN" + . S BMXPRVP=-1 F S BMXPRVP=$O(^BMXTMP($J,BMXFACP,BMXPRVP)) Q:BMXPRVP="" D + . . S BMXPRV=$P($G(^DIC(16,BMXPRVP,0)),U) S:BMXPRV="" BMXPRV="UNKNOWN" + . . S BMXCODP=-1 F S BMXCODP=$O(^BMXTMP($J,BMXFACP,BMXPRVP,BMXCODP)) Q:'+BMXCODP D + . . . D CODLVL(BMXCODP,.BMXCOD,.BMXLVL) + . . . S BMXI=BMXI+1 + . . . S BMXSVC=$P(^BMXTMP($J,BMXFACP,BMXPRVP,BMXCODP),U) + . . . S BMXMIN=$P(^BMXTMP($J,BMXFACP,BMXPRVP,BMXCODP),U,2) + . . . S BMXFEE=$P(^BMXTMP($J,BMXFACP,BMXPRVP,BMXCODP),U,3) + . . . S ^BMXTEMP($J,BMXI)=BMXFAC_U_BMXPRV_U_BMXCOD_U_BMXLVL_U_BMXSVC_U_BMXMIN_U_BMXFEE_BMXRD + . . . Q + . . Q + . Q + S BMXI=BMXI+1 + S ^BMXTEMP($J,BMXI)=$C(31) + Q + ; +CALCMIN(BMXCODP,BMXMIN) ; + ;Returns Minutes for code BMXCOD + N BMXANOD + S BMXMIN=0 + Q:'$D(^AUTTADA(BMXCODP,0)) + S BMXANOD=^AUTTADA(BMXCODP,0) + ;S BMXLVL=$P(BMXANOD,U,5) + S BMXMIN=$P(BMXANOD,U,4) + Q + ; +CALCFEE(BMXCODP,BMXFEE) ; + ;Returns FEE for code BMXCOD. Only works for ANMC local fee field + N BMXANOD + S BMXFEE=0 + Q:'$D(^AUTTADA(BMXCODP,0)) + S BMXANOD=^AUTTADA(BMXCODP,0) + S BMXFEE=+$P(BMXANOD,U,12) + Q + ; +CODLVL(BMXCODP,BMXCOD,BMXLVL) ; + ;Returns Name and Level of code at ADACODP + N BMXANOD + S BMXCOD="",BMXLVL="" + Q:'$D(^AUTTADA(BMXCODP,0)) + S BMXANOD=^AUTTADA(BMXCODP,0) + S BMXCOD=$P(BMXANOD,U) + S BMXLVL=$P(BMXANOD,U,5) Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADO.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADO.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADO.m (revision 1147) @@ -0,0 +1,157 @@ +BMXADO ; IHS/CIHA/GIS - RPC CALL: GENERATE AN ADO SCHEMA STRING AND DATA SET ; + ;;4.1000;BMX;;Apr 17, 2011 + ; SS^BMXADO: RPC EP FROM WINDOWS/WEB APP TO GENERATE A SCHEMEA STRING (& OPTIONALLY, A DATA SET AS WELL) + ; THE SCHEMA DEFINITION AND MAP IS STORED IN THE 'BMX ADO SCHEMA' FILE + ; THIS ROUTINE GENERATES THE SCHEMA STRING. BMXADOV GENERATES THE DATA SET THAT GOES WITH THE SCHEMA STRING. + ; IF THERE IS AN ERROR, XXX(1) WILL CONTAIN "ERROR|msg"_$C(30) WHERE 'msg' IS THE ERROR MESSAGE + ; E.G."ERROR|Invalid schema IEN" + ; + ; +SSD(OUT,SIEN,DAS,VSTG,JSTG) ;Debug entry point + ;D DEBUG^%Serenji("SSD^BMXADO(.OUT,SIEN,DAS,VSTG,JSTG)") ; DEBUGGER ENTRY POINT + Q + ; + ; +SS(OUT,SIEN,DAS,VSTG,JSTG) ; EP - RETURN THE SCHEMA STRING IN AN ARRAY + ; OUT=OUTPUT VARIABLE (PASSED BY REFERENCE) + ; THE OUTPUT ARRAY IS GENERATED FROM DATA IN THE 'BMX ADO SCHEMA' FILE AND THE FILEMAN DATABASE + ; RECORDS ARE SEPARATED WITH $C(30). FIELDS ARE SEPARATED BY "^". FIELD PROPERTIES ARE SEPARATED BY "|". + ; ONE RECORD PER OUTPUT NODE. + ; 1ST RECORD IS THE "INTRODUCTION RECORD": "@@@meta@@@BMXIEN|FILE #|DA STRING" + ; THE SECOND RECORD IS THE HEADER RECORD. THE REST ARE THE DATA RECORDS + ; RECORD FORMAT: FILE#|FIELD#|DATA TYPE|LENGTH|FIELDNAME|READONLY|KEYFIELD|NULLOK_$C(30) + ; SIEN=SCHEMA NAME OR IEN FROM BMX ADO SCHEMA FILE + ; DAS= "DA" STRING: STRING FOR DEFINING PARENT FILES + ; EXAMPLE: "4,8," CORRESPONDS TO DA(2), DA(1). + ; PRIMARILY USED AS A "SEED" FOR RE-ENTRY - IF INDEX IS PRESENT. + ; IF NOT A SEED, DO NOT INCLUDE THE BOTTOM LEVEL IEN: DA; E.G., "4,8," + ; DO NOT CONFUSE WITH "IENS STRING" OF FILEMAN SILENT CALLS + ; VSTG=VIEW STRING INSTRUCTIONS (SEE BMXADOV FOR DETAILS) + ; JSTG=JOIN STRING INSTRUCTIONS (SEE BMXADOVJ FOR DETAILS) + ; + N X,Y,DIC,ERR + S OUT=$NA(^TMP("BMX ADO",$J)) K @OUT ; DEFINE THE OUTPUT ARRAY CLOSED REFERENCE + X ("S "_$C(68)_"UZ(0)=$C(64)") ; INSURE PRIVELEGES + S X="MERR^BMXADO",@^%ZOSF("TRAP") ; SET MUMPS ERROR TRAP + I '$L(SIEN) S ERR="Missing schema ID" D ERR(ERR) Q + I 'SIEN S DIC="^BMXADO(",DIC(0)="M",X=SIEN D ^DIC S SIEN=+Y I Y=-1 S ERR="Invalid schema ID" D ERR(ERR) Q + I '$D(^BMXADO(SIEN,0)) S ERR="Invalid/missing schema" D ERR(ERR) Q ; SCHEMA MUST EXIST + N FIEN,FLDIEN,TOT,STG,B,C,X,%,LEVEL,Y,SF + S FIEN=$P(^BMXADO(SIEN,0),U,2) + I '$D(^DD(FIEN,0)) S ERR="Invalid/missing file number in schema file" D ERR(ERR) Q ; INVALID FILE NUMBER + S SF=$$CKSUB(FIEN,DAS) I SF=-1 S ERR="Invalid DA string" D ERR(ERR) Q ; INVALID DA STRING + S C=",",B="|",TOT=0 ; THESE LOCALS, ALONG WITH KERNEL VARIABLES, ARE ALWAYS AVAILABLE TO ALL ROUTINES AND SUBROUTINES +JEP ; EP-RECURSION RE-ENTRY POINT FOR JOINS + I $G(SUB),$G(SF) S ERR="Invalid request" D ERR(ERR) Q ; CAN'T DO JOIN WITH A SUBFILE AS THE PRIMARY FILE + S TOT=TOT+1,@OUT@(TOT)="@@@meta@@@BMXIEN"_B_FIEN_B_DAS_U + I $G(SUB) S TOT=TOT+1,@OUT@(TOT)=FIEN_"|.0001|N|15|DA(1)|TRUE|FALSE|FALSE^" + I $G(SF) D SFH(SF) ; SUBFILE HEADERS + S TOT=TOT+1,@OUT@(TOT)=FIEN_"|.001|N|15|BMXIEN|TRUE|TRUE|FALSE^" ; KEY FIELD PART OF HEADER RECORD + S FLDIEN=0 + F S FLDIEN=$O(^BMXADO(SIEN,1,FLDIEN)) Q:'FLDIEN S STG=$G(^BMXADO(SIEN,1,FLDIEN,0)) I $L(STG) D ; REST OF HEADER RECORD + . S X=FIEN_B_$P(STG,U)_B_$P(STG,U,2)_B_$P(STG,U,3)_B_$P(STG,U,4)_B + . S %=$S($P(STG,U,5):"TRUE",$P($G(^BMXADO(+$G(IEN),0)),U,3):"TRUE",1:"FALSE") S X=X_%_B ; READ ONLY + . S %=$S($P(STG,U,6):"TRUE",1:"FALSE") S X=X_%_B ; THIS IS A KEY FIELD + . S %=$S($P(STG,U,7):"TRUE",1:"FALSE") S X=X_%_U ; NULL VALUE IS OK (NOT MANDATORY FOR TRANSACTION) + . S TOT=TOT+1 + . S @OUT@(TOT)=X + . Q + I TOT'>2 Q ; NOTHING TO PROCESS + S %=@OUT@(TOT) I $E(%,$L(%))=U S $E(%,$L(%))=$C(30),@OUT@(TOT)=% ; END OF RECORD MARKER + I $G(VSTG)="",$G(DFLD)=.001 S VSTG="~~~" ; SIMPLE LOOKUP INTO DETAILS FILE BY IEN + I '$L($G(VSTG)) Q ; REQUEST IS FOR SCHEMA ONLY - NO DATA +DATASET S VSTG=SIEN_"~"_DAS_"~"_VSTG + I $O(^TMP("BMX JOIN",$J,1,+$G(SDETAIL),0)) D JVIEW Q ; JOIN ITERATION ; NO SUPPORT FOR EXTENDED JOINS + D VIEW^BMXADOV(.OUT,VSTG,.TOT) ; APPEND A DATA SET TO A SCHEMA STRING + I '$L($G(JSTG)) S JSTG=$P(VSTG,"~",11,999) ; INCLUDED FOR BKWD COMPATIBILITY ;JOIN INSTRUCTIONS SPAN MULTIPLE ~ PIECES (11,999) BECAUSE OF POSSIBLE NESTED VSTG + I $L(JSTG) D JOIN^BMXADOVJ(SIEN,JSTG) ; ADD DATA SET(S) TO FULFIL THE JOIN REQUEST + Q + ; +JVIEW ; JOIN VIEW - SET XCNT AND RESET THE VSTG + N XCNT,DA,NODE,% + S NODE=999999999999 + F S NODE=$O(@OUT@(NODE),-1) Q:'NODE I @OUT@(NODE)["|.001|" Q + I 'NODE Q ; INVALID SCHEMA - JOIN CANCELLED + I '$L($P(VSTG,"~",3)),'$G(SUB),$G(DFLD)'=.001 Q ; THERE MUST BE AN INDEX OR SUBFILE FOR A JOIN TO TAKE PLACE + D JFLD^BMXADOVJ ; STUFF VALUES FOR JOIN FLDS INTO INTRO SEGMENT OF THE SCHEMA + S XCNT=NODE + S DA=0 + F S DA=$O(^TMP("BMX JOIN",$J,1,SDETAIL,DA)) Q:'DA D D VIEW^BMXADOV(.OUT,VSTG,.TOT) ; APPEND JOINED DATA SETS TO A SCHEMA STRING + . I $P(VSTG,"~",3)="AA",$L($P(VSTG,"~",10)) D Q + .. S %=$P(VSTG,"~",10) + .. S $P(%,"|",1)=DA + .. S $P(VSTG,"~",10)=% + .. Q + . I $G(SUB) S DAS=DA_",",VSTG=SDETAIL_"~"_DA_",~~" Q ; SUBFILE ITERATOR + . I $P(VSTG,"~",3)="AA",$G(FIEN)=9000011 S $P(VSTG,"~",4,5)=DA_"~"_DA Q ; PROBLEM LIST ITERATOR + . S $P(VSTG,"~",4,5)=DA_"~"_DA ; SINGLE IEN ITERATOR + . Q + Q + ; +SFH(DAS) ; SUBFILE HEADERS + N L,LEV,PCE,X,%,Z,FLD + S Z="000000000",L=$L(DAS,",") + F PCE=1:1:L-1 D + . S LEV=(L+1)-PCE + . S FLD="."_$E(Z,1,LEV+1)_1 + . S TOT=TOT+1 + . S @OUT@(TOT)=FIEN_B_FLD_"|I|10|BMXIEN"_(LEV-1)_"|TRUE|TRUE|FALSE"_U ; FIX + . Q + Q + ; +CKSUB(FILE,DAS) ; CHECK THE DA STRING FOR VALIDITY AND MAKE THE DA ARRAY + N LEVEL,FIEN + S FIEN=FILE + F LEVEL=1:1 S FIEN=$G(^DD(FIEN,0,"UP")) Q:'FIEN ; COUNT THE LEVELS + I LEVEL'=$L($G(DAS),",") Q -1 ; LEVEL MATCHES DA STRING + I LEVEL=1 Q "" ; INVALID DA STRING + Q DAS + ; +LINE(FILE) ; GET FIELD VALUES + N LINE,NODE,STG,DIR,FLD,PF,SET,X,DS,DP + S LINE="" + S NODE=2,Y="" F S NODE=$O(ARR(NODE)) Q:'NODE S STG=ARR(NODE) I $L(STG) D I Y=U Q + . S FLD=$P(STG,B,2) I 'FLD S Y=U Q + . I $P(STG,B,6)="TRUE" Q ; READ ONLY + . S DIR("A")=$P(STG,B,5) I '$L(DIR("A")) S Y=U Q + . S X=$P($G(^DD(+$G(FILE),FLD,0)),U,2) + . I X["P" D Q + .. S PF=+$P(X,"P",2) I 'PF S Y=U Q + .. S DIR(0)="P^"_PF_":EQMZ" + .. D DIR + .. Q + . I X["S" D Q + .. S DIR(0)="S^"_$P(^DD(FILE,FLD,0),U,3) + .. D DIR + .. Q + . I X["D" D Q + .. S DS=$P(^DD(FILE,FLD,0),U,5) + .. I DS'["%DT=""" S DIR(0)="D^::EX" D DIR Q + .. S DP=$P(DS,"%DT="_$C(34),2) S DP=$P(DP,$C(34,32),1) + .. S DIR(0)="D^::"_DP + .. D DIR + .. Q + . S DIR="F" + . D DIR + . Q + Q LINE + ; +DIR D ^DIR + I Y?1."^" S Y=U Q + I Y?1.N1"^".E S Y="`"_+Y + S LINE=LINE_U_Y + Q + ; +MERR ; MUMPS ERROR TRAP + N X + X ("S X=$"_"ZE") + S X="MUMPS error: """_X_"""" + D ERR(X) + Q + ; +ERR(ERR) ;EP - BMX ADO SCHEMA ERROR PROCESSOR + N X + S X="ERROR|"_ERR_$C(30) + S @OUT@(1)=X + Q + ; Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADO2.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADO2.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADO2.m (revision 1147) @@ -0,0 +1,80 @@ +BMXADO2 ; IHS/CIHA/GIS - BMX ADO RECORDSET UTILS ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; +GEN(BMXY,BMXF) ;EP - Generate an ADO Schema string from a list of fields + ;BMXY Is an out-parameter called by reference. + ;On return, BMXY will be a zero-based one-dimensional array each node of which will + ;contain the schema corresponding to the fields info in BMXF + ; + ;BMXF is an in-parameter called by reference. + ;On input, BMXF will contain the field info on which to build the schema string. + ; + ;Field info in BMXF is arranged in a zero-based one-dimensional array. + ;Node 0 of BMXF contains the KEYFIELDNAME^FILENUMBER^READONLY + ;where KEYFIELDNAME is the name of the unique key field in the database and + ;FILENUMBER is the FileMan file number and + ;READONLY denotes whether the entire recordset is updateable. + ; + ;Each subsequent node of the BMXF arrray contains field info in the form + ;1FILE#^2FIELD#^3LENGTH^4DATATYPE^5ALIAS^6READONLY^7KEYFIELD^8NULLOK + ;If FILE# AND FIELD# are defined, the LENGTH and DATATYPE will be taken from the FileMan data dictionary + ;If ALIAS is defined, the schema string will use ALIAS as the column name + ;READONLY, KEYFIELD and NULLOK are binary fields. Note that there should be only one field + ;in the recordset having KEYFIELD=TRUE + ; + ;New column info format is @@@meta@@@KEYFIELD|FILE# + ; For each field: ^1FILE#|2FIELD#|3DATATYPE|4LENGTH|5FIELDNAME|6READONLY|7KEYFIELD|8NULL ALLOWED + ;example: + ;BMXY(0)="@@@meta@@@BMXIEN|2160010^" + ;BMXY(1)="2160010|.001|I|10|BMXIEN|TRUE|TRUE|FALSE^" + ; + S BMXY(0)="@@@meta@@@"_$G(BMXF(0)) + N BMXI,BMXS,BMXFM,BMXDD,BMXTYP,BMXLEN,BMXLEN2,BMXNAM,BMXKEY,BMXREAD,BMXNULL + S BMXI=0 + F S BMXI=$O(BMXF(BMXI)) Q:'+BMXI D + . N BMXFM,BMXDD,BMXTYP,BMXLEN,BMXLEN2,BMXNAM,BMXKEY,BMXREAD,BMXNULL + . S (BMXDD,BMXTYP,BMXLEN,BMXLEN2,BMXNAM,BMXKEY,BMXREAD,BMXNULL)="" + . S BMXFM=0 ;Flag indicating whether BMXF(BMXI) is a FileMan field + . S BMXY(BMXI)="" + . I BMXF(BMXI) S BMXY(BMXI)=$P(BMXF(BMXI),U,1,2) S BMXFM=1 + . I BMXFM D ;Look in ^DD for attributes + . . S BMXDD=$G(^DD($P(BMXF(BMXI),U),$P(BMXF(BMXI),U,2),0)) + . . ;column name + . . S BMXNAM=$P(BMXDD,U) + . . S BMXNAM=$TR(BMXNAM," ","_") + . . ;Data type + . . I $P(BMXDD,U,2)["P" S BMXDD=$$PTYPE(BMXDD) + . . S BMXTYP=$P(BMXDD,U,2) + . . S BMXTYP=$S(BMXTYP["F":"T",BMXTYP["S":"T",BMXTYP["D":"D") + . . I BMXTYP["N" S BMXTYP=$S($P(BMXTYP,",",2)>0:"N",1:"I") + . . ;default columnn lengths based on type + . . I BMXTYP="N"!(BMXTYP="I") S BMXLEN=$P(BMXDD,U,2),BMXLEN=$P(BMXLEN,","),BMXLEN=$E(BMXLEN,3,$L(BMXLEN)) + . . I BMXTYP="I" S BMXLEN2=$P(BMXDD,U,2),BMXLEN2=$P(BMXLEN,",",2),BMXLEN=BMXLEN+BMXLEN2+1 + . . I BMXTYP="T" S BMXLEN=0 + . . I BMXTYP="D" S BMXLEN=30 + . . S BMXNULL="TRUE" S:$P(BMXDD,U,2)["R" BMXNULL="FALSE" + . ;Look in BMXF for user-specified attributes + . S:$P(BMXF(BMXI),U,5)]"" BMXNAM=$P(BMXF(BMXI),U,5) ;Alias + . ;Set KEY, NULL and READONLY + . S BMXNULL="TRUE",BMXREAD="TRUE",BMXKEY="FALSE" + . I $P(BMXF(BMXI),U,7)="TRUE" S BMXKEY="TRUE",BMXNULL="FALSE",BMXREAD="TRUE" + . E S:$P(BMXF(BMXI),U,8)]"" BMXNULL=$P(BMXF(BMXI),U,8) S:$P(BMXF(BMXI),U,6)]"" BMXREAD=$P(BMXF(BMXI),U,6) + . ;Set BMXY node + . S $P(BMXY(BMXI),"|",3)=BMXTYP + . S $P(BMXY(BMXI),"|",4)=BMXLEN + . S $P(BMXY(BMXI),"|",5)=BMXNAM + . S $P(BMXY(BMXI),"|",6)=BMXREAD + . S $P(BMXY(BMXI),"|",7)=BMXKEY + . S $P(BMXY(BMXI),"|",8)=BMXNULL + ; + Q +PTYPE(BMXDD) ; + ;Traverse pointer chain to retrieve data type of pointed-to field + N BMXFILE + I $P(BMXDD,U,2)'["P" Q BMXDD + S BMXFILE=$P(BMXDD,U,2) + S BMXFILE=+$P(BMXFILE,"P",2) + S BMXDD=$G(^DD(BMXFILE,".01",0)) + S BMXDD=$$PTYPE(BMXDD) + Q BMXDD Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOF.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOF.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOF.m (revision 1147) @@ -0,0 +1,231 @@ +BMXADOF ; IHS/CIHA/GIS - RPC CALL FOR EXTENDED FUNCTIONALITY OF BMXNet UTILITIES ; 4/6/11 12:52pm + ;;4.1000;BMX;;Apr 17, 2011 + ; THIS IS THE ADO RECORDSET FILER: ADO -> FILEMAN + ; VISIT FILE UPDATES REPRESENT A SPECIAL CASE HTAT IS MANAGED IN BMXADOF1 + ; INCLUDES TRANSACTION CONTROLS + ; + ; + ; + N DAS,FILE,DATA,OUT S DAS=7,FILE=19707.82,DATA="2.02|120/83" D FILE(.OUT,FILE,DAS,DATA) W !,OUT Q + ; +FILED(OUT,FILE,DAS,DATA) ; RPC CALL: UNIVERSAL FILEMAN RECORD UPDATER UTILITY + ; D DEBUG^%Serenji("FILED^BMXADOF(.OUT,FILE,DAS,DATA)") ; DEBUGGER ENTRY POINT + Q + ; +FILEX(OUT,FILE,DAS,DATA) ; EP - RPC CALL: INSURES THAT BMXIEN IS VALID - MOJO ONLY + I '$L($G(DATA)) D + . S DATA="",%="" + . F S %=$O(DATA(%)) Q:'% S DATA=DATA_DATA(%) ; CONVERT DATA ARRAY INTO A DATA STRING + . Q + I '$L(DATA) Q + I DATA["999|" S DAS=+$P(DATA,"999|",2) I 'DAS S DAS="" ; FORCE NEW ENTRY + D FILE(.OUT,FILE,$G(DAS),DATA) + Q + ; +FILE(OUT,FILE,DAS,DATA) ;EP - RPC CALL: UNIVERSAL FILEMAN RECORD UPDATER UTILITY + ; + ; OUT = OUTBOUND MESSAGE RETURNED TO CALLINING APP. 'OK'=SUCCESSFUL TRANSACTION, 'OK|5' NEW RECORD DAS=5 ADDED + ; IF TRANSACTION FAILS, AN ERROR MESSAGE IS PASSED + ; FILE = VALID FILEMAN FILE OR SUB-FILE NUMBER - WHERE UPDATE IS TO OCCUR + ; DAS = THE DA STRING - TYPICALLY THE FILE INTERNAL ENTRY NUMBER OF THE RECORD TO BE UPDATED + ; IF THIS IS A SUB-FILE, DAS MUST BE PRECEDED BY PARENT DAS(S) IN COMMA SEPARATED STRING - TOP TO BOTTOM ORDER + ; DAS MAY BE PRECEDED BY '+' = ALL FIELDS ARE MANDATORY (REQD FOR TRANSACTION) OR '-' = DELETE THIS ENTRY + ; IF DAS STRING = NULL OR = '+', THIS MEANS ADD A NEW RECORD WITH DATA SUPPLIED IN DATA PARAMETER + ; EXAMPLES OF DAS STRINGS: '1' (EDIT RECORD #1), '5,2,-7' (DELETE RECORD #7 IN 3RD LEVEL SUBFILE) + ; DATA = DATA STRING OR ARRAY REFERENCE. DATA CAN BE PASSED USING THE .PARAM SYNTAX + ; DATA STRING FORMAT: FIELD#|VALUE_$C(30)_FIELD#|VALUE_$C(30)_...FIELD#|VALUE_$C(30) + ; $C(30) [AKA EOR] IS THE DATA ELEMENT SEPARATOR + ; $C(30) IS USED AS THE DATA DELIMITER BECAUSE OTHER CHARACTERS LIKE '^' COULD APPEAR IN THE VALUE PIECE! + ; EA FIELD# MAY BE PRECEED BY '+' = MANDATORY (REQD FOR TRANSACTION) OR '-' = DELETE THE VALUE OF THIS FIELD + ; EXAMPLE: ".03|1/5/46"_EOR_"-.02|"_EOR_"+.09|139394444"_EOR NOTE -.02| IS SAME AS .02|@ OR .02| + ; '+' IN FRONT OF THE DAS IS THE SAME AS PUTTING A '+' IN FRONT OF EVERY FIELD# IN THE DATA STRING + ; + ;;;;;DEBUG CODE!!!! + S ^ZSAM("FILE")=FILE + S ^ZSAM("DAS")=DAS + S ^ZSAM("DATA")=DATA + ;;;;;DEBUG CODE!!!! + ; + ; + N VENDUZ,VUZ + M VENDUZ=DUZ S VUZ=$C(68,85,90) + N OREF,CREF,DIC,DIE,DA,DR,X,Y,%,I,FLD,CNT,FNO,VAL,@VUZ,TFLG,DFLG,TOT,UFLG,XTFLG,GTFLG,GDFLG,LVLS,IENS + I $G(FILE)=9000010 N AUPNPAT,AUPNDOB,AUPNDOD,AUPNVSIT,AUPNTALK,APCDOVRR S (APCDOVRR,AUPNTALK)=1 ; THE VISIT FILE IS UPDATED IN THIS TRANSACTION + X ("M "_$C(68,85,90)_"=VENDUZ S "_$C(68,85,90)_"(0)="_$C(34,64,34)) K VENDUZ ; ELININATES PERMISSION PROBLEMS + S OUT="",FLD="",GTFLG=0,GDFLG=0 + S X="MERR^BMXADOF",@^%ZOSF("TRAP") ; SET MUMPS ERROR TRAP + I '$D(^DD(+$G(FILE))) S OUT="Invalid file number" Q ; FILE # MUST BE VALID + S DAS=$G(DAS) I $E(DAS)="," S DAS=$E(DAS,2,99) ; ACCURATE IF NON SUB-FILE DAS STRING DOSN'T CONTAIN A "," + S LVLS=$L(DAS,",") + S %=FILE F CNT=1:1 S %=$G(^DD(%,0,"UP")) I '% Q ; COUNT FILE/SUB-FILE LEVELS IN THE DATA DICTIONARY + I LVLS'=CNT S OUT="Invalid DAS string" Q ; LEVELS IN DAS STRING MUST MATCH LEVELS IN THE DATA DICTIONARY + I $E(DAS)="-" S DAS=$E(DAS,2,99),GDFLG=1 ; GLOBAL DELETE FLAG + I $E(DAS)="+" S DAS=$E(DAS,2,99),GTFLG=1 ; GLOBAL TRANSACTION FLAG, ROLLBACK IF ANY FIELD FAILS TO UPDATE + I LVLS>1 F I=1:1:LVLS D I DAS="ERR" S OUT="Invalid DAS string" Q ; MAKE DAS ARRAY. MIRRORS THE DA() ARRAY + . I I=LVLS S DAS=$P(DAS,",",I) Q ; SET DAS OF SUBFILE + . S %=$P(DAS,",",I) I '% S DAS="ERR" Q + . S DAS(LVLS-I)=% ; SET DAS(S) OF PARENT FILE(S). LIKE DA(), THE LARGER THE DAS SUBSCRIPT, THE HIGHER THE LEVEL + . Q + I DAS="ERR" S OUT="Update cancelled. Invalid DAS string" Q + I DAS="Add"!(DAS="ADD") S DAS="" + S %=$E(DAS) I %="-" S GDFLG=1,DAS=$E(DAS,2,99) ; YET ANOTHER WAY TO SET GLOBAL DELETE FLAG + S %=$$REF(FILE,.DAS) ; GET OPEN REF, CLOSED REF, AND IENS STRING + S OREF=$P(%,"|"),CREF=$P(%,"|",2),IENS=$P(%,"|",3) I $L(OREF),$L(CREF) + E S OUT="Update cancelled. Invalid file definition/global reference" Q ; ERROR REPORT + I DAS,'$D(@CREF@(DAS)) S OUT="Update cancelled. Invalid DAS" Q ; IF THERE IS AN DAS, IT MUST BE VALID + I '$G(DAS),FILE=9000010,'$$VVAR^BMXADOF2(DATA) Q ; VISIT FILE ADD REQUIRES THAT SPECIAL VARIABLES BE PRESENT AND VALID + I 'GDFLG,DAS,DATA[".01|@" S GDFLG=1 ; ALTERNATE WAY TO SET GLOBAL DELETE FLAG: REMOVE .01 FIELD + I GDFLG,'DAS S OUT="Deletion cancelled. Missing DAS" Q ; CAN'T DO DELETE WITHOUT AN DAS + I GDFLG D DIK(OREF,DAS) S OUT="Record deleted|"_DAS Q ; DELETE AND QUIT + S UFLG=$S($G(DAS):"E",1:"A") ; SET UPDATE FLAG: ADD OR EDIT + I '$L($G(DATA)) D I '$L($G(DATA)) S OUT="Update cancelled. Missing/invalid data string" Q ; COMPRESS DATA ARRAY INTO A SINGLE STRING + . S DATA="",%="" + . F S %=$O(DATA(%)) Q:'% S DATA=DATA_DATA(%) ; CONVERT DATA ARRAY INTO A DATA STRING + . Q + S %=$L(DATA) S %=$E(DATA,%-1,%) D ; CHECK FOR PROPER TERMINATION OF DATA STRING + . I %=$C(30,31) Q ; PROPER TERMINATION + . I $E(%,2)=$C(30) S DATA=DATA_$C(31) Q + . I $E(%,2)=$C(31) S DATA=$E(DATA,1,$L(DATA-1))_$C(30,31) + . S DATA=DATA_$C(30,31) + . Q + S TOT=$L(DATA,$C(30)) I 'TOT S OUT="Update cancelled. Missing data string" Q +SPEC S DATA=$$SPEC^BMXADOFS(FILE,DATA,UFLG) ; BASED ON FILE IEN, SPECIAL MODS MAY BE MADE TO THE DATA STRING + S TOT=$L(DATA,$C(30)) I 'TOT S OUT="Update cancelled. SPEC analysis failed." Q + F CNT=1:1:TOT S %=$P(DATA,$C(30),CNT) I $L(%) S DATA(CNT)=% ; BUILD PRIMARY FIELD ARRAY + S %=$G(DATA(1)) I %=""!(%=$C(31)) S OUT="Update cancelled. Missing data string" Q + S %=DATA(CNT) I %[$C(31) S %=$P(%,$C(31),1),DATA(CNT)=% ; STRIP OFF END OF FILE MARKER + F CNT=1:1:TOT S X=$G(DATA(CNT)) I $L(X) D ; BUILD SECONDARY FIELD ARRAY + . S TFLG=0,DFLG=0 + . I $E(X)="+" S TFLG=1,X=$E(X,2,999),$P(FLD,U)=1 + . I $E(X)="-" S DFLG=1,X=$E(X,2,999) + . S FNO=$P(X,"|"),VAL=$P(X,"|",2) + . I '$D(^DD(FILE,+$G(FNO),0)) S:$L(OUT) OUT=OUT_"~" S OUT=OUT_FNO_"|Invalid field number" Q + . I DFLG,VAL'="" S:$L(OUT) OUT=OUT_"~" S OUT=OUT_FNO_"|Invalid deletion syntax" Q ; CANT DELETE IF A VALUE IS SENT + . I VAL="@" S DFLG=1 ; SYNC DFLG AND VAL + . S FLD(FNO)=VAL_U_TFLG_U_DFLG + . I FNO=.01,TFLG S $P(FLD,U,2)=1 + . Q + I $P($G(FLD(.01)),U,3),UFLG="A" S OUT="Record deletion cancelled. Missing DAS" Q ; CAN'T DELETE A RECORD WITHOUT A VALID DAS + I $P($G(FLD(.01)),U,3)!($G(GDFLG)) S UFLG="D" ; DELETION +DELREC I UFLG="D" D DIK(OREF,DAS) S OUT="OK" Q ; DELETE THE RECORD + I UFLG="A",'$L($P($G(FLD(.01)),U)) S OUT="Record addition cancelled. Missing .01 field" Q ; CAN'T ADD A RECORD WITHOUT A VALID .01 FIELD +DINUM I UFLG="A",$G(^DD(FILE,.01,0))["DINUM=X" D ; IF DINUM'D RECORD EXISTS, SWITCH TO MOD MODE + . S %=FLD(.01) + . I $E(%)="`" S %=+$E(%,2,99) + . I '$D(@CREF@(%,0)) Q ; OK TO ADD BRAND NEW RECORD BUT EXISTING RECORDS MUST BE EDITED + . K FLD(.01) + . S DAS=%,UFLG="E" + . Q +ADDREC I UFLG="A" D ADD(OREF) Q ; ADD A NEW ENTRY TO A FILE +EDITREC I UFLG="E" D EDIT(OREF,DAS) Q ; EDIT AN EXISTING RECORD + Q + ; +DIK(DIK,DA) ; DELETE A RECORD + ; PATCHED BY GIS 9/28/04 TO FIX PROBLEMS WITH SUBFILE DELETION + I '$G(DAS(1)) G DIK1 ; CHECK FOR SUBFILE DELETION + N DA,IENS,I,DIK + I '$G(FILE) Q + S I=0,IENS=DAS_"," + M DA=DAS + F S I=$O(DAS(I)) Q:'I S IENS=IENS_DAS(I)_"," + S DIK=$$ROOT^DILFD(FILE,IENS) I '$L(DIK) Q +DIK1 D ^DIK + D ^XBFMK + Q + ; +ADD(DIC) ; ADD A NEW ENTRY TO A FILE + N X,Y,%,DA,DN,UP,SB,DNODE,ERR + S X=$P($G(FLD(.01)),U) I '$L(X) S OUT="Unable to add a new record" Q + S X=$$POINT(FILE,.01,X) ; ADD ACCENT GRAV IF NECESSARY + S X=""""_X_"""" ; FORCE A NEW ENTRY + S DIC(0)="L" + I $O(DAS(0)) D I $G(ERR) S Y=-1 G AFAIL ; GET DIC("P") IF NECESSARY + . S %=0 F S %=$O(DAS(%)) Q:'% S DA(%)=DAS(%) ; CREATE THE DA ARRAY + . S UP=$G(^DD(FILE,0,"UP")) I 'UP S ERR=1 Q + . S SB=$O(^DD(UP,"SB",FILE,0)) I 'SB S ERR=1 Q + . S DIC("P")=$P($G(^DD(UP,SB,0)),U,2) I '$L(DIC("P")) S ERR=1 Q + . S DN=DIC_"1,0)" I $D(DN) Q + . S @DN=(U_DIC("P")_U_U) ; CREATE THE DICTIONARY NODE + . Q +ADIC D ^DIC +AFAIL I Y=-1 S OUT="Unable to add a new record" G AX + I $O(FLD(0)) D EDIT(DIC,+Y) Q + S OUT="OK"_"|"_+Y +AX D ^XBFMK + Q + ; +EDIT(DIE,DA) ; EDIT AN EXISTING RECORD + N DR,RFLG,ERR,FNO,VAL,TFLG,RESULT,MSG,DIERR,DISYS,SF,APCDALVR + S FNO=0,DR="",APCDALVR="" + I UFLG="A" S OUT="OK New record added|"_DA + F S FNO=$O(FLD(FNO)) Q:'FNO S X=FLD(FNO) I $L(X) D I $G(RFLG) Q ; CHECK EA FIELD AND BUILD THE DR STRING AND ERROR STRING + . S VAL(FNO)=$P(X,U),TFLG=$P(X,U,2) I '$L(VAL(FNO)) Q + . S SF=$$WP(FILE,FNO) + . I SF D WORD(FILE,DA,FNO,CREF,VAL(FNO)) Q ; WORD PROCESSING FIELDS MANAGED SEPARATELY + . S VAL(FNO)=$$POINT(FILE,FNO,VAL(FNO)) ; ADD ACCENT GRAV IF NECESSARY + . K ERR,RESULT + . I VAL(FNO)="@"!(VAL(FNO)="") S RESULT="@" + . I FNO=.01,UFLG="A" S:$E(VAL(.01))="`" VAL(.01)=$E(VAL(.01),2,999) Q ; NO NEED TO EDIT THE .01 FIELD OF A RECORD THAT HAS JUST BEEN CREATED + . I FILE\1=9000010,$L($P(FILE,".",2))=2,UFLG="E",(FNO=.02!(FNO=.03)) Q ; CAN'T EDIT EXISTING PT AND VISIT FIELDS OF V FILES + . I FILE\1=9000010,$L($P(FILE,".",2))=2,UFLG="A",FNO=.03,VAL(.03)?1"`"1.N S %=+$E(VAL(.03),2,99) I $D(^AUPNVSIT(%,0)) S RESULT=% G E1 + . I FILE=9000011,FNO=.07,VAL(.07)?1.N S RESULT=VAL(.07) G E1 ; THE VALIDITY CHECK FAILS - SO BYPASS THIS +CHK . I VAL(FNO)'="@" D CHK^DIE(FILE,FNO,"",VAL(FNO),.RESULT,.ERR) +E1 . I RESULT=U D Q + .. S MSG=$G(ERR("DIERR",1,"TEXT",1),"Failed FileMan data validation") + .. I $L(OUT) S OUT=OUT_"~" + .. I TFLG!GTFLG S RFLG=1,OUT=FNO_"|"_MSG Q + .. S OUT=OUT_FNO_"|"_MSG + .. Q + . S VAL(FNO)=RESULT + . I $L(DR) S DR=DR_";" + . I RESULT="@" S DR=DR_FNO_"////@" Q ; DELETE THIS VALUE + . S DR=DR_FNO_"////^S X=VAL("_FNO_")" ; BUILD DR STRING + . Q + I $G(RFLG) D:UFLG="A" DIK(DIE,DA) S OUT="Record update cancelled"_"|"_OUT G EX ; TRANSACTION ROLLBACK FLAG IS SET, ENTRY DELETED (ADD MODE) OR UPDATE CANCELLED (EDIT MODE) + S %=0 F S %=$O(DAS(%)) Q:'% S DA(%)=DAS(%) ; JUST IN CASE THIS IS A MILTIPLE, CREATE THE DA ARRAY +DIE L +@CREF@(DA):2 I $T D ^DIE L -@CREF@(DA) G:OUT["valid" EX S OUT="OK" S:UFLG="A" OUT=OUT_"|"_DA G EX ; SUCCESS!!!! + S OUT="Update cancelled. File locked" ; FILE LOCKED. UNABLE TO UPDATE + I $L(FLD),UFLG="A" D DIK(DIE,DA) ; ROLLBACK THE NEW RECORD +EX D ^XBFMK ; CLEANUP + Q + ; +REF(FILE,DAS) ; GIVEN A FILE/SUBFILE NUMBER & DAS ARRAY, RETURN THE FM GLOBAL REFERENCE INFO: OREF|CREF|IENS + N OREF,CREF,IENS,I,X + S IENS=$$IENS^DILF(.DAS) I '$L(IENS) Q "" + S OREF=$$ROOT^DILFD(FILE,IENS) I '$L(OREF) Q "" + S CREF=$$CREF^DILF(OREF) I '$L(CREF) Q "" + Q (OREF_"|"_CREF_"|"_IENS) + ; +POINT(FILE,FNO,VAL) ; ADD ACCENT GRAV IF NECESSARY + I $E(VAL)="`" Q VAL + I $P($G(^DD(FILE,FNO,0)),U,2)["P",VAL=+VAL,VAL\1=VAL S VAL="`"_VAL + Q VAL + ; +WP(FILE,FLD) ; RETURN THE SUBFILE NUMBER IF IT IS A WORD PROCESSING FIELD + N SF,DTYPE + S SF=$P($G(^DD(+$G(FILE),+$G(FLD),0)),U,2) I 'SF Q 0 + S DTYPE=$P($G(^DD(SF,.01,0)),U,2) + I DTYPE["W" Q SF + Q 0 + ; +WORD(FILE,DA,FLD,CREF,VAL) ; SUFF TEXT ENTRY INTO THE WP MULTIPLE FIELD + N SS,TOT,A,B,I + S SS=+$P($G(^DD(FILE,FLD,0)),U,4) I SS="" Q + I VAL="@"!(VAL="") K @CREF@(DA,SS) Q ; DELETE THE WP RECORD: REMOVE DICTIONARY NODE AND DATA + S TOT=0 + F Q:'$L(VAL) D + . S A=$E(VAL,1,80),VAL=$E(VAL,81,999999) ; PEEL OFF AN 80 CHARACTER DATA BLOCK FROM THE FRONT OF THE TEXT STRING + . I $L(A) S TOT=TOT+1,B(TOT)=A ; BUILD THE TEMP ARRAY + . Q + I '$D(B(1)) Q ; NOTHING TO STORE SO QUIT + S @CREF@(DA,SS,0)="^^"_TOT_U_TOT_U_DT ; SET DICTIONARY NODE + F I=1:1:TOT S @CREF@(DA,SS,I,0)=B(I) ; SET DATA NODES + Q + ; +MERR ; MUMPS ERROR TRAP + N ERR,X + X ("S X=$"_"ZE") + S ERR="M ERROR: "_X + S OUT=ERR + Q + ; Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOF1.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOF1.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOF1.m (revision 1147) @@ -0,0 +1,75 @@ +BMXADOF1 ; IHS/CIHA/GIS - RPC CALL FOR EXTENDED FUNCTIONALITY OF BMXNet UTILITIES ; + ;;4.1000;BMX;;Apr 17, 2011 + ; UPDATE FILEMAN WITH AN ADO RECORD SET FROM A WINDOWS/WEB APPLICATION + ; + ; + D BAFM(.OUT,$NA(^TMP("BMX ADO",6))) ; W !!! ZW OUT K OUT Q + ; +BAFM(OUT,CREF) ; EP- RPC: PASS DATA FROM A STD BROKER ADO ARRAY TO FILEMAN AND RETURN THE ACK MSG IN 'OUT' ARRAY + I '$L($G(CREF)) Q ; REFERENCE MUST EXIST + I '$D(@CREF) Q ; DATASET MUST EXIST + N NODE,STG,DATA,SCHEMA,X,ECNT,CNT + S OUT="DONE",ECNT=0,CNT=0 +PEEL S NODE=0,STG="" ; PEEL DATA OFF THE ARRAY AND FILE IT + F S NODE=$O(@CREF@(NODE)) Q:'NODE D ; LOOP THRU THE NODES TO BUILD A STRING. + . S X=@CREF@(NODE) I X="" Q + . S STG=STG_X + . I STG[$C(30) D S STG="" Q ; WHEN YOU HIT $C(30), PROCESS THE CURRENT STRING, AND THEN START A NEW STRING. + .. S STG=$TR(STG,$C(30),"") ; REMOVE THE EOR CHARACTER $C(30) FROM THE END OF THE STRING + .. I STG["@@@meta@@@" S SCHEMA=STG Q ; GET SCHEMA STRING. THEN KEEP LOOPING TO GET THE DATA STRINGS + .. D PREP(.OUT,SCHEMA,STG) ; PREP DATA STRING FOR FILING, AND THEN FILE THE DATA + .. Q + . Q + K @CREF ; CLEAN UP + I ECNT=0 S OUT(0)="OK" Q ; SUMMARY NODE OF THE OUTPUT ARRAY + S OUT(0)=ECNT_" error(s) detected in this transaction" + Q + ; +PREP(OUT,SCHEMA,DATA) ; PREPARE DATA FOR THE ADO FILER + N TOP,LEV,C,B,%,DA,DAS,PCE,MAX,S,D,FILE,DSTG,MAND,FLD,VAL,MSG + S C=",",B="|",DAS="" + S %=$P(SCHEMA,U,2) S TOP=$P(%,B,2) + S LEV=$L(TOP)-3 I LEV=2 S DAS=+DATA_C + S SCHEMA=$P(SCHEMA,U,2,999) + S MAX=$L(SCHEMA,U) + S FILE=+SCHEMA I '$D(^DD(FILE,0)) S ERR="Update failed. Missing/invalid file number" D ERR(ERR) Q +SPEC ; CHECK FOR SPECIAL CASES + I FILE=9000011,SCHEMA'["|.05|" G DSTG + I FILE=9000010.07,SCHEMA'["|.04|" G DSTG + I FILE=9000010.18,SCHEMA'["|.04|" G DSTG + I FILE=9000013,SCHEMA'["|.04|" G DSTG + I FILE=9000014,SCHEMA'["|.04|" G DSTG + I FILE'=9000010.07,FILE'=9000011,FILE'=9000013,FILE'=9000014,FILE'=9000010.18 + E I '$$NARR^BMXADOF2 Q ; GET IEN OF PROVIDER NARRATIVE AND SUBSTITUE THIS VALUE IN THE DATA STG +DSTG ; BUILD THE ADD/UPDATE STRING FOR THE EBCU FILER + S DA=+DATA,DAS=DAS_DA,DSTG="" + F PCE=2:1:MAX D + . S S=$P(SCHEMA,U,PCE),VAL=$P(DATA,U,PCE) + . I $P(S,B,6)="TRUE" Q ; READ ONLY + . S FLD=$P(S,B,2) I 'FLD Q ; INVALID SCHEMA PIECE + . I $E(FLD,1,3)=".00" Q ; IEN NOT DATA + . I FLD["ID" Q ; DON'T FILE THE IDENTIFIERS + . I SCHEMA[(B_FLD_"IEN"),FLD'["IEN",$L(VAL) Q ; WAIT FOR THE LOOKUP VALUE, BYPASS CURRENT FIELD + . S FLD=+FLD + . I $P(S,B,8)'="TRUE" S FLD="+"_FLD ; MANDATORY FIELD + . E I VAL="" S FLD="-"_FLD ; DELETE THE VALUE + . I FLD?.1E1".01" D Q ; MAKE SURE THAT THE .01 FIELD IS FIRST! + .. I $L(DSTG) S DSTG=FLD_B_VAL_$C(30)_DSTG Q ; APPEND .01 FIELD TO THE FRONT OF AN EXISTING UPDATE STRING + .. S DSTG=FLD_B_VAL ; START A NEW UPDATE STRING WITH THE .01 FIELD + .. Q + . I $L(DSTG) S DSTG=DSTG_$C(30) ; $C(30) IS THE "COLUMN" DELIMITER FOR DATA TO BE ENETERED IN THE TABLE + . S DSTG=DSTG_FLD_B_VAL ; "|" IS THE DATA ELEMENT DELIMITER, SEPARATING FIELD NAME AND FIELD VALUE + . Q +FILE D FILE^BMXADOF(.MSG,FILE,DAS,DSTG) ; THE DATA STRING IS PREPARED. NOW SEND IT TO THE EBCU FILER. + I $E(MSG,1,2)'="OK" S ECNT=ECNT+1 + S CNT=CNT+1 S OUT(CNT)=MSG + ; S DSTG=$TR(DSTG,$C(30),"}") W !,DSTG ; TEMP OUTPUT - REMOVE THIS LINE AFTER TESTING COMPLETED! + Q + ; +ERR(ERR) ; + I '$L($G(ERR)) Q + S ECNT=$G(ECNT)+1 + S CNT=CNT+1 + S OUT(CNT)=ERR + Q + ; Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOF2.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOF2.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOF2.m (revision 1147) @@ -0,0 +1,57 @@ +BMXADOF2 ; IHS/CIHA/GIS - RPC CALL FOR EXTENDED FUNCTIONALITY OF BMXNet UTILITIES ; + ;;4.1000;BMX;;Apr 17, 2011 + ; THIS ROUTINE CONTAINS SPECIAL ENTRY POINTS FOR UPDATING RPMS + ; + ; + ; +VVAR(DATA) ; EP-CHECK SPECIAL VARIABLES REQUIRED FOR UPDATING THE VISIT FILE + I '$L(DATA) S OUT="Update cancelled. Missing data string" Q 0 + N X,I,Y,VDATE,%DT + K AUPNPAT,AUPNDOB,AUPNDOD,AUPNVSIT ; THE VARS ARE NOT NEW'D SINCE THEY WILL BE USED BY THE CALLING ROUTINE + S AUPNTALK=1,AUPNOVRR=1 + S X=DATA S X=$TR(X,($C(30)_"+"),$C(30)) S X=$TR(X,($C(30)_"-"),$C(30)) S X=$TR(X,($C(30)_"`"),$C(30)) S DATA=X ; STRIP OFF TRANSACTION FLAGS FROM FIELD NUMBERS + S X=$P(DATA,"|",2),X=$P(X,$C(30)),VDATE=-1 + I $E(X,1,7)?7N S VDATE=X + E S %DT="T" D ^%DT S VDATE=Y + I VDATE=-1 S OUT="Update cancelled. Visit timestamp misssing/invalid" Q 0 + S Y=+$P(DATA,($C(30)_".05|"),2) I 'Y S OUT="Update cancelled. Patient data missing" Q 0 ; FAILED TO FIND THE PATIENT IEN + S AUPNPAT=Y + S AUPNDOB=$P($G(^DPT(AUPNPAT,0)),U,3) I 'AUPNDOB S OUT="Update cancelled. Missing DOB" Q 0 + I AUPNDOB>VDATE S OUT="Update cancelled. Patient born afer visit date???" Q 0 + S AUPNDOD=$P($G(^DPT(AUPNPAT,.35)),U) + I AUPNDOD,AUPNDOD FILEMAN + ; CONTAINS SPECIAL ENTRY POINT FOR RPMS DATA ENTRY + ; + ; + ; + ; D SS^BMXADO(.XXX,53,"","~~~~~VMEAS~BMXADOFD~1.244A||PU\60|WT\175|HT\70") Q + ; D SS^BMXADO(.XXX,58,"X","AC~53~53~~~NOTES~BMXADOFD~53") Q + N FILE,DAS,DATA S FILE=9000010.07,DAS="+" + S DATA=".01|`8718"_$C(30)_".02|`1"_$C(30)_".03|`71168"_$C(30)_".04|DM--2"_$C(30,31) + D FILE^BMXADOF(.XXX,FILE,DAS,DATA) Q + ; +VMEAS(DATA,IENS,MAX,OUT,TOT) ; VIEW MEASUREMENTS: CUSTOM ITERATOR + ; DATA=VCN|ALL|MTYPE1\VAL1|MTYPE2\VAL2|...|MTYPEn\VALn + N VAL,CNT,P,S,PTIEN,VIEN,%,X,Y,TYPE,N,ALL,STG,MEAS,MIEN,IX + S P="|",S="\",N=0 + I '$G(TOT) Q "" + I '$L(OUT) Q "" + S VIEN=$P(DATA,P) I '$L(VCN) Q "" + S PTIEN=$P($G(^AUPNVSIT(VIEN,0)),U,5) I 'PTIEN Q "" + F CNT=2:1 S X=$P(DATA,P,CNT) Q:'$L(X) D ; CREATE PRELIMINARY DATA ARRAYS + . S VAL=$P(X,S,2) ; VALUE MUST EXIST + . I '$L(VAL) Q + . S TYPE=$P(X,S) ; TYPE MUST EXIST + . I '$L(TYPE) Q + . S MIEN=$O(^AUTTMSR("B",TYPE,0)) I 'MIEN Q + . S MEAS=$P($G(^AUTTMSR(MIEN,0)),U,2) I '$L(MEAS) Q + . S N=N+1 + . S VAL(N)=VAL + . S TYPE(N)=MIEN_U_TYPE_U_MEAS + . S IX(MIEN)=N + . Q +MG S N=0 F S N=$O(VAL(N)) Q:'N D + . S TOT=TOT+1 + . S @OUT@(TOT)=+TYPE(N)_U_$P(TYPE(N),U,2)_U_"`"_PTIEN_U_"`"_VIEN_U_VAL(N)_U_$P(TYPE(N),U,3)_$C(30) + . Q + Q "" + ; +ICDVAL(CODE) ; EP-RPC-VERIFY ICD CODE BY RETURNING ITS IEN + I '$L($G(CODE)) Q "" + N IEN + S IEN=$O(^ICD9("BA",CODE_" ",0)) + I $L($T(CODEN^ICDCODE)) S IEN=+$$CODEN^ICDCODE(CODE,80) I IEN'>0 S IEN="" + I 'IEN Q "" + Q IEN + ; +FACNIEN(PIEN,FIEN) ;EP - GIVEN A PROBLEM IEN AND FACILITY IEN, RETURN THE FACILITY-NOTE IEN + I '$D(^AUPNPROB(+$G(PIEN),0)) Q "" + I '$D(^DIC(4,+$G(FIEN),0)) Q "" + N NFIEN + S FNIEN=$O(^AUPNPROB(PIEN,11,"B",FIEN,0)) I FNIEN Q FNIEN ; IF AN FNIEN EXISTS RETURN IT + ; OTHERWISE-CREATE THE FM STUB NODES FOR THE FACILITY SUBFILE + S FNIEN=$O(^AUPNPROB(PIEN,11,999999),-1)+1 + S ^AUPNPROB(PIEN,11,FNIEN,0)=FIEN + S ^AUPNPROB(PIEN,11,FNIEN,11,0)="^9000011.1111IA^^" + S ^AUPNPROB(PIEN,11,"B",FIEN,FNIEN)="" + Q FNIEN + ; +NEXTPBN(DFN,FIEN) ; RETURN THE NEXT AVAILABLE PROBLEM NUMBER FOR A PATIENT AT THE FACILITY + N MAX,PIEN,X,Y + S MAX=0,PIEN=0 + F S PIEN=$O(^AUPNPROB("AC",DFN,PIEN)) Q:'PIEN D ; FIND ALL PROBLEMS FOR THIS PATIENT + . S X=$G(^AUPNPROB(PIEN,0)) I '$L(X) Q "" + . I $P(X,U,6)'=FIEN Q ; ONLY CHECK NUMBERS AT THIS FACILITY + . S Y=$P(X,U,7) + . I Y>MAX S MAX=Y ; GET THE HIGHEST NUMBER THUS FAR + . Q + S MAX=(MAX\1)+1 ; GET NEXT AVAILABLE INTEGER + Q MAX + ; +NN W $$NEXTNOTE(221,4585) Q +NEXTNOTE(PIEN,FIEN) ; RETRUN THE NEXT NOTE NUMBER FOR A PROBLEM AND FACILITY + I '$D(^AUPNPROB(+$G(PIEN),0)) Q "" + I '$D(^DIC(4,+$G(FIEN),0)) Q "" + N MAX,NIEN,FNIEN,X,Y + S MAX=0,NIEN=0 + S FNIEN=$$FACNIEN^BMXADOFD(PIEN,FIEN) I 'FNIEN Q "" + F S NIEN=$O(^AUPNPROB(PIEN,11,FNIEN,11,NIEN)) Q:'NIEN D + . S X=$G(^AUPNPROB(PIEN,11,FNIEN,11,NIEN,0)) I '$L(X) Q + . S Y=+X + . I Y>MAX S MAX=Y + . Q + S MAX=MAX+1 + Q MAX Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOFS.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOFS.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOFS.m (revision 1147) @@ -0,0 +1,208 @@ +BMXADOFS ; IHS/CIHA/GIS - RPC CALL FOR EXTENDED FUNCTIONALITY OF BMXNet UTILITIES ; 31 Jul 2009 12:42 PM + ;;4.1000;BMX;;Apr 17, 2011 + ; THIS IS THE ADO RECORDSET FILER: ADO -> FILEMAN + ; CONTAINS SPECIAL CODE RELATED TO FILING PROPLEMS, POVS, FAMILY HX, PERSONAL HX AND NOTES. + ; + ; + ; +PAT ; TEST PROBLEM ADD + S DATA=".01|`8257"_$C(30)_".02|`53"_$C(30)_".03|"_DT_$C(30)_".05|C-POX"_$C(30)_".06|`4585"_$C(30)_".12|I"_$C(30,31) + D FILE^BMXADOF(.XXX,9000011,"",DATA) W !,XXX K XXX,DATA Q + ; +PET ; TEST PROB EDIT + S DATA=".01|250.00"_$C(30)_".03|"_DT_$C(30)_".05|HI MOM"_$C(30)_".12|I"_$C(30,31) + D FILE^BMXADOF(.XXX,9000011,"1757",DATA) W !,XXX K XXX,DATA Q + ; +TDP ; TEST PROBLEM DELETE + S DATA=$C(31) + D FILE^BMXADOF(.XXX,9000011,"-1757",DATA) W !,XXX K XXX,DATA Q + ; +TPOV ; ADD POV TEST + S DATA=".01|`8718"_$C(30)_".02|`53"_$C(30)_".03|`3909"_$C(30)_".04|DM---I"_$C(30)_".12|P"_$C(30,31) + D FILE^BMXADOF(.XXX,9000010.07,"",DATA) W !,XXX K XXX,DATA Q + ; +TH ; HX TEST + S DATA=".01|250.00"_$C(30)_".02|`53"_$C(30)_".03|JUL 15,2004"_$C(30)_".04|FAMILY HX OF LUNG CA"_$C(30,31) + D FILE^BMXADOF(.XXX,9000014,"",DATA) W !,XXX K XXX,DATA Q + ; +TNOTE ; TEST ADDING A NOTE TO A PROBLEM + N DATA,XXX,PROBIEN,FACNIEN,FACIEN,DAS + S PROBIEN=3,FACIEN=4587 + S FACNIEN=$$FACNIEN(PROBIEN,FACIEN) ; YOU MUST SPECIFY THE PROBLEM IEN AND THE FACILITY IEN + S DAS=PROBIEN_","_FACNIEN_"," + S DATA=".03|NEW NOTE #2"_$C(30,31) ; THE DATA STRING JUST CONTAINS THE NOTE FIELD. + ; THE OTHER FIELDS (INCLUDING .01) ARE ADDED BY BMXADOF + D FILE^BMXADOF(.XXX,9000011.1111,DAS,DATA) W !,XXX + Q + ; + ; ----------------------------------------------------------------------------------------------------- + ; +SPEC(FILE,DATA,UFLG) ;EP - SPECIAL DATA MODS FOR SPECIFIC FILES + I FILE=9000010.07 S DATA=$$POV(DATA) Q DATA + I FILE=9000011 S DATA=$$PROB(DATA,$G(UFLG)) Q DATA + I FILE=9000013!(FILE=9000014) S DATA=$$HX(DATA) Q DATA + I FILE=9000011.1111 S DATA=$$NOTE(DATA,$G(DAS(2)),$G(DAS(1))) Q DATA + ; I FILE=9000010.18,DATA'["|.04|" G DSTG + Q DATA + ; +HX(DATA) ; INPUT STRING TRANSFORM FOR PHX AND FHX + N NARR,NIEN,%,A,B,X,Y,%DT + I DATA[".01|`" G HNARR + S DATA=$$ICD(DATA,.01) I DATA="" Q "" +HNARR I DATA'[".04|'" G HDT + S DATA=$$NARR(DATA,.04) +HDT I DATA'[".03|" Q DATA + S X=+$P(DATA,".03|",2) I X?7N Q DATA + S %DT="" D ^%DT + I Y'?7N Q DATA + S A=$P(DATA,".03|") + S B=$P(DATA,".03|",2) S B=$P(B,$C(30),2) + S DATA=A_".03|"_Y + I $L(B) S DATA=DATA_$C(30)_B + Q DATA + ; +POV(DATA) ; POV INPUT STRING TRANSFORM + N NARR,NIEN,% + I DATA[".01|`" G PVNARR + S DATA=$$ICD(DATA,.01) I DATA="" Q "" +PVNARR I DATA'[".04|'" Q DATA + S DATA=$$NARR(DATA,.04) + Q DATA + ; +PROB(DATA,UFLG) ; PROBLEM LIST INPUT STRING TRANSFORM + N NARR,NIEN,%,PNUM,FACIEN,DFN,X,A,B +PNARR I DATA'[".05|" G PICD + S %=$P(DATA,".05|",2) + S NARR=$P(%,$C(30)) + I NARR'?1"`"1.N S DATA=$$NARR(DATA,.05) ; STUFF THE NARR LOOKUP VALUE IN THE DATA STRING + I '$L(DATA) Q "" +PICD S %=$P(DATA,"|") I %'=.01,DATA'[($C(30)_".01|") G PNUM + S DATA=$$ICD(DATA,.01) I DATA="" Q "" +PNUM I $G(UFLG)="E" Q DATA ; STOP HERE IF IN EDIT MODE + I $P(DATA,($C(30)_".07|"),2) G TODAY ; GET NEXT PROB NUM + S DFN=+$P(DATA,".02|`",2) + I 'DFN S DATA="" Q "" + S FACIEN=+$P(DATA,".06|`",2) + I 'FACIEN Q "" + S PNUM=$$NEXTPBN(DFN,FACIEN) + I 'PNUM Q "" + S X=$L(DATA,$C(30)) + S A=$P(DATA,$C(30),1,X-1),B=$P(DATA,$C(30),X) + S DATA=A_$C(30)_".07|"_PNUM_$C(30)_B +TODAY I $P(DATA,($C(30)_".08|"),2) Q DATA ; GET TODAY'S DATE + S X=$L(DATA,$C(30)) + S A=$P(DATA,$C(30),1,X-1),B=$P(DATA,$C(30),X) + S DATA=A_$C(30)_".08|"_$G(DT)_$C(30)_B + Q DATA + ; +NOTE(DATA,PIEN,FNIEN) ; GIVEN A DATA STRING CONTAINING THE NOTE, THE PROBLEM IEN, AND THE FAC-NOTE IEN: + ; ADD NOTE # AND STATUS TO THE DATA STRING + I $G(DATA)'[".03|" Q "" + I '$D(^AUPNPROB(+$G(PIEN),11,+$G(FNIEN),0)) Q "" + N NUM + I DATA'[".04|" S DATA=".04|A"_$C(30)_DATA + I DATA'[".01|" D + . S NUM=$$NEXTNOTE(PIEN,FNIEN) + . I 'NUM Q + . S DATA=".01|"_NUM_$C(30)_DATA + Q DATA + ; +TI N XXX S XXX=$$ICD(".01|250.00"_$C(30)_".02|123"_$C(30)_".03|ABC",.01) W !,$TR(XXX,$C(30),"{") Q +ICD(DATA,FLD) ; VERIFY ICD CODE AND GET LOOKUP VALUE + I '$G(FLD) Q "" + I '$L($G(DATA)) Q "" + N %,A,B + S %=$P(DATA,"|") + I %=FLD D Q DATA + . S %=$P(DATA,"|",2) + . S %=$P(%,$C(30)) + . I %?1"`"1.N Q + . S %=$O(^ICD9("BA",%_" ",0)) + . I $L($T(CODEN^ICDCODE)) S %=+$$CODEN^ICDCODE(%,80) I %<0 S %="" + . I '% S DATA="" Q + . S A=$P(DATA,"|") + . S B=$P(DATA,"|",2,999) + . S B=$P(B,$C(30),2,999) + . S DATA=A_"|`"_% + . I $L(B) S DATA=DATA_$C(30)_B + . Q + S %=$P(DATA,($C(30)_FLD_"|"),2) D + . S %=$P(%,$C(30)) + . I %?1"`"1.N Q DATA + . S %=$O(^ICD9("BA",%_" ",0)) + . I $L($T(CODEN^ICDCODE)) S %=+$$CODEN^ICDCODE(%,80) I %<0 S %="" + . I '% S DATA="" Q + . S A=$P(DATA,($C(30)_FLD_"|")) + . S B=$P(DATA,($C(30)_FLD_"|"),2,999) + . S B=$P(B,$C(30),2,999) + . S DATA=A_$C(30)_FLD_"|`"_% + . I $L(B) S DATA=DATA_$C(30)_B + . Q + Q DATA + ; +NARR(DATA,FLD) ; SUBSTITUTE A LOOKUP VALUE FOR NARRATIVE DATA IN THE DATA STRING + N A,B,C,X,Y,DIC,Z + I '$G(FLD) Q "" + I '$L($G(DATA)) Q "" + S Z=FLD_"|" + S A=$P(DATA,Z) + S B=$P(DATA,Z,2) + S NARR=$P(B,$C(30)) + S NARR=$$UP^XLFSTR(NARR) ; CONVERT ALL NARRATIVE TO UPPERCASE + S C=$P(B,$C(30),2,999) + S DIC="^AUTNPOV(",DIC(0)="L",X=NARR + D ^DIC I Y=-1 Q "" + S DATA=A_FLD_"|`"_+Y + I $L(C) S DATA=DATA_$C(30)_C + D ^XBFMK + Q DATA + ; +FACNIEN(PIEN,FIEN) ; GIVEN A PROBLEM IEN AND FACILITY IEN, RETURN THE FACILITY-NOTE IEN + I '$D(^AUPNPROB(+$G(PIEN),0)) Q "" + I '$D(^DIC(4,+$G(FIEN),0)) Q "" + N FNIEN + S FNIEN=$O(^AUPNPROB(PIEN,11,"B",FIEN,0)) I FNIEN Q FNIEN ; IF AN FNIEN EXISTS RETURN IT + ; OTHERWISE-CREATE THE FM STUB NODES FOR THE FACILITY SUBFILE + S FNIEN=$O(^AUPNPROB(PIEN,11,999999),-1)+1 + S ^AUPNPROB(PIEN,11,FNIEN,0)=FIEN + S ^AUPNPROB(PIEN,11,FNIEN,11,0)="^9000011.1111IA^^" + S ^AUPNPROB(PIEN,11,"B",FIEN,FNIEN)="" + Q FNIEN + ; +NEXTPBN(DFN,FIEN) ; RETURN THE NEXT AVAILABLE PROBLEM NUMBER FOR A PATIENT AT THE FACILITY + N MAX,PIEN,X,Y + S MAX=0,PIEN=0 + F S PIEN=$O(^AUPNPROB("AC",DFN,PIEN)) Q:'PIEN D ; FIND ALL PROBLEMS FOR THIS PATIENT + . S X=$G(^AUPNPROB(PIEN,0)) I '$L(X) Q "" + . I $P(X,U,6)'=FIEN Q ; ONLY CHECK NUMBERS AT THIS FACILITY + . S Y=$P(X,U,7) + . I Y>MAX S MAX=Y ; GET THE HIGHEST NUMBER THUS FAR + . Q + S MAX=(MAX\1)+1 ; GET NEXT AVAILABLE INTEGER + Q MAX + ; +NN W $$NEXTNOTE(3,1) Q +NEXTNOTE(PIEN,FNIEN) ; RETRUN THE NEXT NOTE NUMBER FOR A PROBLEM AND FACILITY-NOTE IEN + I '$D(^AUPNPROB(+$G(PIEN),11,+$G(FNIEN),0)) Q "" + N MAX,NIEN,X,Y + S MAX=0,NIEN=0 + F S NIEN=$O(^AUPNPROB(PIEN,11,FNIEN,11,NIEN)) Q:'NIEN D + . S X=$G(^AUPNPROB(PIEN,11,FNIEN,11,NIEN,0)) I '$L(X) Q + . S Y=+X + . I Y>MAX S MAX=Y + . Q + S MAX=MAX+1 + Q MAX + ; +PIENN(PIEN) ; GIVEN A PROBLEM IEN, RETURN PROBLEM NARRATIVE (ICD) + N X,IIEN,NIEN,NARR,ICD + S X=$G(^AUPNPROB(PIEN,0)) I '$L(X) Q "" + S IIEN=$P(X,U) I 'IIEN Q "" + S NIEN=$P(X,U,5) I 'NIEN Q "" + I $L($T(ICDDX^ICDCODE)) S ICD=$P($$ICDDX^ICDCODE(IIEN),U,2) I 1 + E S ICD=$P($G(^ICD9(IIEN,0)),U) + I '$L(ICD) Q "" + S NARR=$P($G(^AUTNPOV(NIEN,0)),U) I '$L(NARR) Q "" + S X=NARR_" ("_ICD_")" + Q X + ; Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOI.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOI.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOI.m (revision 1147) @@ -0,0 +1,82 @@ +BMXADOI ; IHS/CIHA/GIS - RPC CALL: GENERATE DATA FOR AN ADO DATASET ; + ;;4.1000;BMX;;Apr 17, 2011 + ; CUSTOM IDENTIFIERS + ; + ; + ; +DEMOID(DA) ; EP-RETURN RPMS DEMOGRAPHIC INFO FOR IDENTIFIER FIELD + N SEX,DOB,CHART,AGE,TRIBE,CC,X,Y,%,STG,FMDOB,NAME,S,SSN,CSTG,LOC,ABB + I '$D(^DPT(+$G(DA),0)) Q "" + S S=" " + S X=$G(^DPT(DA,0)),SEX=$P(X,U,2),Y=$P(X,U,3),NAME=$P(X,U),SSN=$P(X,U,9) + I '$L(NAME) Q "" + I Y,$G(DT) S AGE=(DT-Y)\10000 + I Y X ^DD("DD") S DOB=Y + S LOC=0,CSTG="" + F S LOC=$O(^AUPNPAT(DA,41,"B",LOC)) Q:'LOC D ; GET ALL THE CHART NUMBERS + . S CHART=$O(^AUPNPAT(DA,41,"B",LOC,0)) I '$L(CHART) Q + . S ABB=$P($G(^AUTTLOC(LOC,0)),U,7) I '$L(ABB) Q + . I $L(CSTG) S CSTG=CSTG_", " + . S CSTG=CSTG_ABB_" #"_CHART + . Q + I $G(DUZ(2)) S CHART=$P($G(^AUPNPAT(DA,41,DUZ(2),0)),U,2) + S %=$P($G(^AUPNPAT(DA,11)),U,8) I % S TRIBE=$P($G(^AUTTTRI(%,0)),U) + S CC=$P($G(^AUPNPAT(DA,11)),U,18) + S STG=NAME + I $L(CSTG) S STG=STG_CSTG_" --" + I $G(AGE),$L(SEX) S STG=STG_S_AGE_" y/o "_SEX + I '$G(AGE),$L(SEX) S STG=STG_S_SEX + I $L($G(DOB)) S STG=STG_S_DOB + I $L($G(SSN)) S STG=STG_S_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9) + I $L($G(TRIBE)) S STG=STG_S_TRIBE + I $L($G(CC)) S STG=STG_S_CC + Q STG + ; +DATE(DATE) ; TEST TRIGGER + Q DATE + ; +NAME(VIEN) ; RETURN THE PATIENT'S NAME + I '$G(VIEN) Q "" + N DFN + S DFN=$P($G(^AUPNVSIT(VIEN,0)),U,5) I 'DFN Q "" + Q $$GET1^DIQ(2,DFN_",",.01) + ; +SEX(VIEN) ; RETURN THE PATIENT'S SEX + I '$G(VIEN) Q "" + N DFN + S DFN=$P($G(^AUPNVSIT(VIEN,0)),U,5) I 'DFN Q "" + Q $$GET1^DIQ(2,DFN_",",.02) + ; +HRN(VIEN) ; RETURN THE CHART NUMBER FOR VISIT TRIGGER + I '$G(VIEN) Q "" + N DFN,LOC + S DFN=$P($G(^AUPNVSIT(VIEN,0)),U,5) I 'DFN Q "" + S LOC=$P($G(^AUPNVSIT(VIEN,0)),U,6) I 'LOC Q "" + Q $$HRN^AUPNPAT(DFN,LOC,2) + ; +DOB(VIEN) ; RETURN THE PATIENT'S DOB + I '$G(VIEN) Q "" + N DFN,LOC + S DFN=$P($G(^AUPNVSIT(VIEN,0)),U,5) I 'DFN Q "" + Q $$DOB^AUPNPAT(DFN,"E") + ; +SSN(VIEN) ; RETURN THE PATIENTS DOB + I '$G(VIEN) Q "" + N DFN,LOC + S DFN=$P($G(^AUPNVSIT(VIEN,0)),U,5) I 'DFN Q "" + Q $$SSN^AUPNPAT(DFN) + ; +VISDATE(VIEN) ; RETURN THE DATE OF THE VISIT + I '$G(VIEN) Q "" + N FMDT + S FMDT=+$G(^AUPNVSIT(VIEN,0))\1 I 'FMDT Q "" + S %=$$FMTE^XLFDT(FMDT,1) + G TD1 + ; +TODAY(VIEN) ; RETURN TODAY'S DATE + I '$G(DT) Q "" + S %=$$FMTE^XLFDT(DT,1) +TD1 S %=$$UP^XLFSTR(%) + S %=$P(%," ",1,2)_$P(%," ",3) + Q % + ; Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOS.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOS.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOS.m (revision 1147) @@ -0,0 +1,266 @@ +BMXADOS ; IHS/CIHA/GIS - UPDATE THE BMX ADO SCHEMA FILE ; 4/5/11 1:54pm + ;;4.1000;BMX;;Apr 17, 2011 + ; ENABLES NAVIGATION TO SUBFILES PRIOR TO UPDATING THE SCHEMA FILE ENTRY + ; + ; + ; +UPDATE ; UPDATE THE SCHEMA FILE + N DIC,X,Y,%,STOP,FIEN,FNAME,SNAME,SIEN +UDIC S DIC("A")="Enter schema name: " ; EP FROM VENPCCTU + S DIC(0)="AEQLM",DIC="^BMXADO(" + D ^DIC I Y=-1 G FIN +SCHEMA S SNAME=$P(Y,U,2),SIEN=+Y + S FIEN=$$FILE(SIEN) I 'FIEN G FIN + I FIEN'=$P($G(^BMXADO(SIEN,0)),U,2) S DIE=DIC,DA=SIEN,DR=".02////^S X=FIEN" D ^DIE + F D FLD(FIEN,SIEN) I $G(STOP) Q ; GET FIELD INFO +FIN D ^XBFMK + Q + ; +FLD(FIEN,SIEN) ; GET THE FIELD + N DIC,X,Y,DIE,DA,DR,FLDIEN,FLDNAME,FLDTYPE,FDEF,TRANS + N %,%Y,HDR,DTYPE,LEN,FARR,I,TOT,PAUSE,PFLAG,IFLAG,IMSG,STG,READ + D FLIST(.FARR,FIEN,0) + S TOT=$O(FARR(9999),-1) I 'TOT S STOP=1 Q + W !,"Select a field from this "_$S($D(^DD(FIEN,0,"UP")):"sub-",1:"")_"file: " + S I=0 F S I=$O(FARR(I)) Q:'I S PAUSE=$$PAUSE(I) Q:PAUSE'="" W I,?3,FARR(I) + I $G(PAUSE)=U S STOP=1 Q + I $G(PAUSE) S Y=PAUSE G FLD1 + S DIR(0)="NO^1:"_TOT_":",DIR("A")="Select a field from the list" K DA D ^DIR K DIR + I 'Y S STOP=1 Q +FLD1 S %=FARR(+Y) + S FLDIEN=+$P(%," [",2),FLDNAME=$P(%," [") + I $$FDEL(SIEN,FLDIEN) Q ; FIELD DELETED + S X=$$FDEF(FIEN,FLDIEN) I '$L(X) W " ??" Q + S DTYPE=$E(X),LEN=+$E(X,2,6) + S DIR(0)="F^1:30",DIR("A")="Column header",DIR("B")=FLDNAME D ^DIR K DIR + S HDR=Y,TRANS=0 + S %=$P($G(^DD(FIEN,FLDIEN,0)),U,2) ; CHECK FM DD TO SEE IF FIELD IS REQUIRED + I %["R" W !,"FileMan requires a non-null value for this field" S %=2 + E W !,"Is null allowed" S %=$S(FLDIEN=.01:2,1:1) D YN^DICN I %Y?1."^" Q + I %=2 S TRANS=1 ; NON NULL VALUE REQUIRED TO COMPLETE THE TRANSACTION OR THERE WILL BE ROLLBACK + I $G(PFLAG) D ; IF POINTER, ASK IF USER WANTS TO AUTOMATICALLY INSERT THE LOOKUP VALUE FIELD IN THE SCHEMA + . W !,"This field is a pointer value (IEN)." + . W !,"Want to automatically insert the lookup value in the schema" + . S %=2 D YN^DICN W ! I %=1 S PFLAG=2 + . Q +IFLG I $G(IFLAG) D ; NON-POINTER .01 FIELD. ASK IF USER WANTS TO REFERENCE IDENTIFIER EP + . W !,"Want to display identifiers with this field" + . S %=2 D YN^DICN W ! I %'=1 Q + . S IMSG="Respond with a valid entry point in the format 'TAG^ROUTINE'." + . W !,"Entry Point to generate Identifiers: " R Y:$G(DTIME,60) E Q ; IHS/OIT/HMW SAC Exemption Applied For + . I Y?1."^" Q + . I Y?1."?" W !,IMSG S IFLAG(0)="!" Q + . I Y'?1U.7UN1"^"1U.7UN S IFLAG(0)="!" W " ??" + . I $L(Y)>2 S IFLAG(0)=Y,IFLAG=2 + . Q + I $G(IFLAG(0))="!" W !,IMSG K IPFLAG(0),IMSG W !!! G IFLG + S DA(1)=SIEN,DIC="^BMXADO("_DA(1)_",1," + S DIC("P")=90093.991,DIC(0)="L",X=FLDIEN + I '$D(^BMXADO(SIEN,1,0)) S ^BMXADO(SIEN,1,0)="^90093.991^^" + D ^DIC I Y=-1 Q + S READ=($P($G(^DD(FIEN,FLDIEN,0)),U,2)["C") ; COMPUTED FIELDS ARE READ ONLY! + S DIE=DIC,DA=+Y + S DR=".02///^S X=DTYPE;.03///^S X=LEN;.04///^S X=HDR;.05///^S X=READ;.06///0;.07///^S X=('TRANS)" + D ^DIE + I $G(IFLAG)=2 D ID + I $G(PFLAG)'=2 Q +LKUP ; AUTOMATICALLY ADD A LOOKUP FIELD TO THE SCHEMA + S X=FLDIEN_"IEN" + D ^DIC I Y=-1 Q + W !,"The LOOKUP field '"_X_"' has been added to the schema",! + S HDR=HDR_"_IEN",DTYPE="I",LEN="00009" + S DIE=DIC,DA=+Y + S DR=".02///^S X=DTYPE;.03///^S X=LEN;.04///^S X=HDR;.05///^S X=READ;.06///0;.07///^S X=('TRANS)" + D ^DIE + Q + ; +ID ; AUTOMATICALLY ADD AN IDENTIFIER REFERENCE + N X,Y,DIE,DR,DA,REF + S X=".01ID",DA(1)=SIEN + S REF=IFLAG(0) I '$L(REF) Q + D ^DIC I Y=-1 Q + W !,"The identifier field '"_X_"' has been added to the schema",! + S HDR=HDR_"_ID",DTYPE="T",LEN="00017" + S DIE=DIC,DA=+Y + S DR=".02///^S X=DTYPE;.03///^S X=LEN;.04///^S X=HDR;.05///^S X=READ;.06///0;.07///^S X=('TRANS);1///^S X=REF" + D ^DIE + Q + ; +FDEL(SIEN,FIELD) ; DELETE AN EXISTING ENTRY FROM THE 'FIELD' MULTIPLE. RETURN '1' IF THE RECORD WAS DELETED + N FIEN,DA,DIK + S FIEN=$O(^BMXADO(SIEN,1,"B",FIELD,0)) I 'FIEN Q 0 ; THIS IS A NEW ENTRY + W !,"This field already is attached to the schema. Want to delete it" + S %=2 D YN^DICN + I %'=1 Q 0 + S DA(1)=SIEN,DIK="^BMXADO("_DA(1)_",1,",DA=FIEN + D ^DIK + S FIEN=$O(^BMXADO(SIEN,1,"B",(FIELD_"IEN"),0)) + I FIEN S DA=FIEN D ^DIK ; DELETE LOOKUP VALUE FIELD AS WELL + W " Done!",! + Q 1 + ; +FDEF(FILE,FIELD) ;EP - GIVEN A FILEMAN FILE AND FIELD, RETURN THE DATA DEFINITION IN ADO FORMAT + N %,X,Y,Z,STG,I,DTYPE,FNAME,LEN,DNAME + I '$D(^DD(+$G(FILE),+$G(FIELD),0)) Q "" + S STG=$G(^DD(FILE,FIELD,0)) I '$L(STG) Q "" ; GET DATA DEF STRING +DTYPE S %="DNSFWCPVM",X=$P(STG,U,2),DTYPE="" ; GET DATA TYPE + F I=1:1:$L(%) S Y=$E(%,I) I X[Y S DTYPE=Y Q + I DTYPE="" Q "" +FNAME S DNAME=$P(STG,U) I '$L(DNAME) Q "" ; FIELD NAME +DDA ; ADO FORMAT + I DTYPE="D" D Q "D"_LEN_DNAME + . S LEN="00021" + . I STG["S %DT=" S %=$P(STG,"S %DT=",2),%=$P(%,$C(34)) + . I $G(FLDIEN)=.01 S IFLAG=1 + . I %["S" S LEN="00019" Q + . I %["T" S LEN="00018" Q + . Q + I DTYPE="N",STG["1N.N" D Q:'LEN "" Q "I"_LEN_DNAME ; INTEGER + . S %=+$P(STG,"K:+X'=X!(X>",2) + . S Y=$L(%) + . S LEN=$E("00000",1,5-$L(Y))_Y + . Q + I DTYPE="N" D Q:'LEN "" Q "N"_LEN_DNAME ; NUMBER (COULD HAVE A DECIMAL VALUE) + . S %=+$P(STG,"!(X?.E1"".""",2) + . S X=+$P(STG,"K:+X'=X!(X>",2) + . S Y=%+($L(+X)) + . S LEN=$E("00000",1,5-$L(Y))_Y + . Q + I DTYPE="F" D Q:'LEN "" Q "T"_LEN_DNAME + . S Y=+$P(STG,"K:$L(X)>",2) + . S LEN=$E("00000",1,5-$L(Y))_Y + . I 'LEN S LEN="00030" + . I $G(FLDIEN)=.01 S IFLAG=1 + . Q + I DTYPE="S" D Q:'LEN "" Q "T"_LEN_DNAME + . S X=$P(STG,U,3),Y=0 + . F I=1:1:$L(X,":") S Z=$P(X,":",2),Z=$P(Z,";"),%=$L(Z) I %>Y S Y=% + . S LEN=$E("00000",1,5-$L(Y))_Y + . Q + I DTYPE="P" S PFLAG=1 Q "T00030"_DNAME + I DTYPE="W" Q "T05000"_DNAME + I DTYPE="V" Q "" + Q "T00250"_DNAME + ; +FILE(SIEN) ; GET THE FILE OR SUBFILE NUMBER + N FNO,FIEN,DIC,X,Y,%,FILE,NSTG,GBL,FNAME,SUB,FARR,TOT,I + S (FILE,FNO)=$P(^BMXADO(SIEN,0),U,2) +OLD I FNO D I $G(FIEN) Q FIEN + . S NSTG=$O(^DD(FNO,0,"NM","")) + . F S FNO=$G(^DD(FNO,0,"UP")) Q:'FNO S NSTG=$O(^DD(FNO,0,"NM",""))_"/"_NSTG +OLD1 . W !,$S(NSTG["/":"Sub-",1:""),"File #",FILE," (",NSTG,") is linked to this schema." + . W !,"Want to keep it" S %=1 + . D YN^DICN I %'=2 W:%=1 " OK" S FIEN=FILE Q + . W !!,"If you change or delete this file number,",!,"all the information in this schema will be deleted." + . W !,"Are you sure you want to do this" S %=2 D YN^DICN + . I %'=1 W !! G OLD1 + . S GBL="^BMXADO("_SIEN_")" + . K @GBL@(1),@GBL@(2) + . S $P(@GBL@(0),U,2)="" + . W !,"This schema definition has been deleted. You may redefine it now" + . Q +NEW S DIC=1,DIC(0)="AEQM" D ^DIC I Y=-1 Q "" + S FNO=+Y,FNAME=$P(Y,U,2) +NEW1 D SC(.FARR,FNO,1) + S TOT=$O(FARR(999999),-1) I 'TOT Q FNO ; NO SUBFILES FOUND + W !!,"The ",FNAME," file contains the following sub-file" I TOT>1 W "s" + W ! + S I=0 F S I=$O(FARR(I)) Q:'I S PAUSE=$$PAUSE(I) Q:PAUSE'="" W I,?3,FARR(I) + I $G(PAUSE)=U Q "" + I $G(PAUSE) S Y=PAUSE G NEW2 + W !!,"Is the schema linked to a sub-file in this list" + S %=2 D YN^DICN I %=2 Q FNO + S DIR(0)="NO^1:"_TOT_":",DIR("A")="Select a sub-file from the list" K DA D ^DIR K DIR + I 'Y Q "" +NEW2 Q +$P(FARR(+Y)," (",2) + ; +PAUSE(I) ; SCROLL CHECK + N % + W ! + I (I#20) Q "" + W "Select a number from the list (1-",(I-1),") or press to continue: " + R %:$G(DTIME,60) E Q "" ; IHS/OIT/HMW SAC Exemption Applied For + I %?1."^" Q U + I $L(%),$D(FARR(I)) Q % + I $L(%) W " ??" H 2 + W $C(13),?79,$C(13) + Q "" + ; +SC(OUT,FILE,MODE) ;EP - SUB CRAWLER. GIVEN A FILE NUMBER RETURN ALL OF ITS DESCENDANT FILES IN AN ARRAY + I '$D(^DD(FILE,"SB")) Q ; NO DESCENDANTS + N TOT,FNO,FNAME,FIEN,LEVEL,NODE,SARR,STG,X,%,UP,ARR + S FIEN=FILE,TOT=0 + D PASS1 + I '$O(ARR(0)) Q +SC2 ; SECOND PASS. BUILD THE INTERMEDIATE ARRAY + S FNO=0 F S FNO=$O(ARR(FNO)) Q:'FNO D + . I $P($G(^DD(FNO,.01,0)),U,2)["W" K ARR(FNO) Q ; WORD PROCESSING FIELDS DO NOT COUNT + . S STG=FNO,UP=FNO + . F S UP=$G(^DD(UP,0,"UP")) Q:'UP S STG=UP_","_STG ; BUILD DESCENDANT STRING + . I $G(MODE) S STG=$$ASTG(STG) + . S STG=$P(STG,",",2,99) ; DONT NEED TOP LEVEL FILE + . I '$L(STG) Q ; SOMETHING IS SCREWED UP + . S LEVEL=$L(STG,",") + . S FNAME=$O(^DD(FNO,0,"NM","")) + . S X="SARR("_STG_")" + . S @X=FNAME_U_LEVEL_U_FNO + . K ARR(FNO) + . Q +SC3 ; 3RD PASS. BUILD OUTPUT ARAY + S NODE="SARR" + F S NODE=$Q(@NODE) Q:NODE="" D + . S X=@NODE + . S TOT=TOT+1 + . S FNAME=$P(X,U) + . S LEVEL=$P(X,U,2) + . S FNO=$P(X,U,3) + . S OUT(TOT)=$E(" ",1,LEVEL)_FNAME_" ("_FNO_")" + . Q + Q + ; +PASS1 ; PASS 1. BUILD THE ARRAY OF ALL SUBFILES + N FNO S FNO=0 + F S FNO=$O(^DD(FIEN,"SB",FNO)) Q:'FNO D + . S ARR(FNO)="" + . I '$D(^DD(FNO,"SB")) Q + . N FIEN S FIEN=FNO + . D PASS1 ; RECURSION!! + . Q + Q + ; +ASTG(STG) ; CONVERT STRING FROM FILE NUMBERS TO FILE NAMES + N PCE,LEV,FNO,NAME + S LEV=$L(STG,",") + ;F PCE=1:1:LEV S FNO=+$P(STG,",",PCE) D I '$L(STG) Q "" ; SMH - *1000* - Invalid Mumps - See below + F PCE=1:1:LEV S FNO=+$P(STG,",",PCE) D + . S NAME=$O(^DD(FNO,0,"NM","")) + . I $E(NAME)="*" S NAME=$E(NAME,2,99) + . I '$L(NAME) S STG="" Q + . S $P(STG,",",PCE)=""""_NAME_"""" + . Q + I '$L(STG) Q "" ; SMH - *1000* correction + Q STG + ; +FLIST(OUT,FILE,MODE) ;EP - GIVEN A FILE RETURN THE FILEDS IN AN ARRAY MODE=0: NUMERIC ORDER, MODE=1: ALPHA ORDER + ; ONLY NON MULTIPLES AND WORD PROCESSING FIELDS ARE LISTED + N FLD,TOT,NAME,ARR,SS,%,WP + S FLD=0,TOT=0 +F1 F S FLD=$O(^DD(FILE,FLD)) Q:'FLD D ; PASS 1 + . S STG=$G(^DD(FILE,FLD,0)) I '$L(STG) Q + . S %=$P(STG,U,2) + . I %,$P($G(^DD(%,.01,0)),U,2)'["W" Q ; EXCLUDE ALL MULTIPLE FIELDS EXCEPT WORD PROCESSING FIELDS + . S WP=0 I % S WP=1 + . S NAME=$P(STG,U) + . S SS=FLD + . I $G(MODE)=1 S %=NAME S:$E(%)="*" %=$E(%,2,99) S SS=% + . S ARR(SS)=FLD_U_NAME_U_WP + . Q +F2 S SS="" + F S SS=$O(ARR(SS)) Q:SS="" D + . S TOT=TOT+1 + . S %=ARR(SS) + . S OUT(TOT)=$P(%,U,2)_" ["_+%_"]"_$S($P(%,U,3):" (word processing)",1:"") + . K ARR(SS) + . Q + Q + ; Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOS1.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOS1.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOS1.m (revision 1147) @@ -0,0 +1,106 @@ +BMXADOS1 ; IHS/CIHA/GIS - UPDATE THE BMX ADO SCHEMA FILE GUI VERSION ; + ;;4.1000;BMX;;Apr 17, 2011 + ; RPC CALLS + ; + ; + ; +DISP(OUT) ; TEMP DISPLAY + N I,X + S I=0 W ! + F S I=$O(@OUT@(I)) Q:'I S X=@OUT@(I) S X=$TR(X,$C(30),"}") S X=$TR(X,$C(31),"{") W !,X + Q + ; +SCHEMA(NAME) ; GIVEN SCHEMA NAME, RETURN THE IEN + N IEN + S IEN=$O(^BMXADO("B",NAME,0)) + Q IEN + ; +FILE ; RETURN A LIST OF FILES + N OUT,%,SIEN + S SIEN=$$SCHEMA("FILEMAN FILES") + D SS^BMXADO(.OUT,SIEN,"","B~B~C~") + D DISP(OUT) R %:$G(DTIME,60) ; IHS/OIT/HMW SAC Exemption Applied For + K ^TMP("BMX ADO",$J) + Q + ; +SF ; RETURN A LIST OF SUBFILES + N OUT,%,SIEN + S SIEN=$$SCHEMA("SUBFILES") + D SS^BMXADO(.OUT,SIEN,"","~~~~~SFIT~BMXADOS1~2~") + D DISP(OUT) R %:$G(DTIME,60) ; IHS/OIT/HMW SAC Exemption Applied For + K ^TMP("BMX ADO",$J) + Q + ; +FLD ; RETURN LIST OF FIELDS FOR A FILE OR SUBFILE + N OUT,%,SIEN + S SIEN=$$SCHEMA("FIELDS") + D SS^BMXADO(.OUT,SIEN,"","~~~~~FLDIT~BMXADOS1~2~") + D DISP(OUT) R %:$G(DTIME,60) ; IHS/OIT/HMW SAC Exemption Applied For + K ^TMP("BMX ADO",$J) + Q + ; +SCH ; RETURN A LIST OF SCHEMAS + N OUT,%,SIEN + S SIEN=$$SCHEMA("SCHEMAS") + D SS^BMXADO(.OUT,SIEN,"","B~~~") + D DISP(OUT) R %:$G(DTIME,60) ; IHS/OIT/HMW SAC Exemption Applied For + K ^TMP("BMX ADO",$J) + Q + ; +SD ; RETURN THE SCHEMA DEFINITION + N OUT,%,SIEN + S SIEN=$$SCHEMA("SCHEMA DEFINITION") + D SS^BMXADO(.OUT,SIEN,"52,","~~~") + D DISP(OUT) R %:$G(DTIME,60) ; IHS/OIT/HMW SAC Exemption Applied For + K ^TMP("BMX ADO",$J) + Q + ; +FLDIT(PARAM,IENS,MAX,OUT,TOT) ; CUSTOM ITERATOR TO DISPLAY FIELDS + N SFARR,CNT,DEL,NUM,NAME,DDT,DLEN,DHDR,DRO,DKEY,DNA,X,Y + D FLIST^BMXADOS(.SFARR,PARAM) + S CNT=0,DEL=" [" + F S CNT=$O(SFARR(CNT)) Q:'CNT D + . S X=SFARR(CNT) I '$L(X) Q + . S NAME=$P(X,DEL) + . ; F Q:$E(NAME)'=" " S NAME=$E(NAME,2,999) + . I '$L(NAME) Q + . S NUM=+$P(X,DEL,2) I 'NUM Q + . S TOT=TOT+1 + . S Y=$$FDEF^BMXADOS(PARAM,NUM) I '$L(Y) Q ; "" + . S DDT=$E(Y),DLEN=+$E(Y,2,6),DHDR=$E(Y,7,99) + . S DRO="NO" S DKEY="NO" S DNA="YES" + . S ^TMP("BMX ADO",$J,TOT)=NUM_U_NAME_U_DDT_U_DLEN_U_DHDR_U_DRO_U_DKEY_U_DNA_$C(30) + Q "" + ; +FNIT(PARAM,IENS,MAX,OUT,TOT) ; CUSTOM ITERATOR TO DISPLAY FILE OR SUBFILE NAME GIVEN FILE NUMBER + N NUM,NAME + S NUM=+PARAM + S NAME="" + Q:'$D(^DD(NUM,0,"NM")) "" + S NAME=$O(^DD(NUM,0,"NM",0)) + S TOT=TOT+1 + S ^TMP("BMX ADO",$J,TOT)=NUM_U_NAME_$C(30) + Q "" + ; +SFIT(PARAM,IENS,MAX,OUT,TOT) ; CUSTOM ITERATOR TO DISPLAY SUBFILES + N SFARR,CNT,DEL,NUM,NAME + D SC^BMXADOS(.SFARR,PARAM) + S CNT=0,DEL=" (" + F S CNT=$O(SFARR(CNT)) Q:'CNT D + . S X=SFARR(CNT) I '$L(X) Q + . S NAME=$P(X,DEL) + . ; F Q:$E(NAME)'=" " S NAME=$E(NAME,2,999) + . I '$L(NAME) Q + . S NUM=+$P(X,DEL,2) I 'NUM Q + . S TOT=TOT+1 + . S ^TMP("BMX ADO",$J,TOT)=NUM_U_NAME_$C(30) + Q "" + ; +SFT(FNAME) ; TRIGGER "YES" TO INDICATE THAT A SUBFILE IS PRESENT WITHIN A FILE + I '$L($G(FNAME)) Q "" + N FIEN + S FIEN=$O(^DIC("B",FNAME,0)) + I 'FIEN Q "" + I '$O(^DD(FIEN,"SB",0)) Q "" + Q "+" + ; Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOV.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOV.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOV.m (revision 1147) @@ -0,0 +1,122 @@ +BMXADOV ; CIHA/CIHA/GIS - RPC CALL: GENERATE DATA FOR AN ADO DATASET + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; + ; + ; VSTG = VIEW STRING: SCHEMA NAME OR IEN~DAS~INDEX~START~STOP~MAX~FORMAT~TAG~ROUTINE~PARAM~JOIN + ; SCHEMA NAME/IEN: FROM THE BMX ADO SCHEMA FILE + ; DAS: THE DA STRING. HIGHEST LEVEL IS FIRST, FOLLOWED BY SUBFILE IENS. CAN BE CONVERTED TO AN 'IENS' STRING. + ; IF THE LAST ',' PIECE OF DAS IS DEFINED, THAT IS USED AS THE CURRENT STARTING SEED POINT FOR THE ITERATOR + ; THE NEXT INDEX VALUE AFTER THE SEED POINT WILL BE THE FIRST ENTRY SELECTED FOR THE CURRENT TRANSACTION + ; INDEX: THE INDEX THAT RUNS THE ITERATOR. IF NULL, THE ITERATOR WULL CYCLE BY IEN + ; START: STARTING LOOKUP VALUE IN THE OVERALL ITERATION (THE FIRST VALUE THAT CAN BE USED IN SPECIFIED INDEX) + ; STOP: THE LAST LOOKUP VALUE IN THE OVERALL ITERATION (THE LAST VALUE USED IN SPECIFIED INDEX) + ; START AND STOP MUST BE IN THE FORMAT (INTERNAL OR EXTERNAL) USED BY THE INDEX + ; IF THE INDEX IS ON A POINTER FIELD, AND POINTED TO FILED IS DINUMNED, THEN THE EXTERNAL VALUE CAN BE USED + ; MAX: MAXIMUM NUMBER OF ENTRIES REURNED IN THE TRANSACTION + ; FORMAT: RETURN INTERNAL OR EXTERNAL VALUES IN THE DATASET + ; TAG AND ROUTINE: ENTRY POINT FOR CUSTOM/COMPLEX ITERATION + ; PARAM: PARAMETER STRING PASSED TO THE ITERATOR ENTRY POINT. + ; ALSO USED WITH THE AA INDEX TO DEFINE PATIENT DFN, V FILE ATTRIBUTE TYPE AND SORT ORDER (C OR R) + ; E.G., 1|WT|R COULD BE PATIENT #1, MEASUREMENT TYPE="WEIGHT" AND REVERSE CHRONOLICAL PRESENTATION OF DATA + ; JOIN: JOIN INSTRUCTIONS; E.G., ...~2,4,.04|2,5,.07|4,9,SUB" + ; + ; +VIEW(OUT,VSTG,TOT) ; EP-VIEW A DATA SET ; GATEWAY TO ALL ITERATORS + ; + ; DON'T CALL THIS EP UNLESS YOU WANT DATA RETURNED WITH THE SCHEMA! + ; INPUT: VSTG AND THE TOTAL NUMBER OF NODES IN THE SCHEMA ARRAY + ; OUTPUT: THE DATA NODES AND THE SEED (SEED IS STUFFED INTO 3RD PIECE OF INTRODUCTORY NODE OF SCHEMA ARRAY) + ; RETURNS THE ADO DATASET IN THE ARRAY SPECIFIED BY 'OUT' + ; THE SEED IS ALWAYS RETURNED IN 'LDA' REGARDLESS OF WHAT ITERATOR IS USED + ; IF ITERATION IS COMPLETED THE SEED WILL HAVE A NULL VALUE + ; + ; + ; + N DAS,DA,IX,START,STOP,MAX,FMT,EP,IENS,OREF,CREF,FIEN,TAG,ROUTINE,X,Y,%,PARAM,NUM,FINFO,LIEN,LDA,LFILE,%DT,T + S SIEN=+$G(VSTG) I SIEN,'$D(^BMXADO(SIEN,0)) S ERR="Invalid schema IEN" D ERR^BMXADO(ERR) Q + I $G(TOT)<2 S ERR="Missing schema string" D ERR^BMXADO(ERR) Q ; MUST HAVE A VALID SCHEMA STRING FOR EACH TRANSACTION +INIT ; INITIALIZE VARIABLES + S T="~" + S FIEN=$P(^BMXADO(SIEN,0),U,2) I '$D(^DD(FIEN,0)) S ERR="Invalid file number in schema file" D ERR^BMXADO(ERR) Q + S DAS=$P(VSTG,T,2),IX=$P(VSTG,T,3) + S START=$P(VSTG,T,4),STOP=$P(VSTG,T,5),MAX=$P(VSTG,T,6) + I $L(START),$L(STOP),START,START=+START,STOP,STOP=+STOP + S %=$T ; NUMERIC START AND STOP + I %,START>STOP S ERR="Invalid start stop pair" D ERR^BMXADO(ERR) Q + I '%,$L(START),$L(STOP),START]STOP S ERR="Invalid start stop pair" D ERR^BMXADO(ERR) Q + I $L(MAX),(MAX'>0!(MAX'=MAX\1)) S ERR="Invalid MAX parameter" D ERR^BMXADO(ERR) Q + S FMT=$P(VSTG,T,7),TAG=$P(VSTG,T,8),ROUTINE=$P(VSTG,T,9),PARAM=$P(VSTG,T,10),NUM=0 + I $L(TAG),'$L(ROUTINE) S ERR="Invalid EP info" D ERR^BMXADO(ERR) Q + S EP=TAG_U_ROUTINE I EP=U S EP="" + I $L(EP) X ("S %=$L($T("_EP_"))") I '% S ERR="Invalid EP info" D ERR^BMXADO(ERR) Q + I FMT='"I" S FMT="" + I MAX="" S MAX=100 + I $G(JOIN) S MAX=999999999 ; MAX IS UNLIMITED FOR SECONDARY DATA SETS DURING JOINS + S IENS=$$IENS(DAS) ; CONVERT DA STRING TO IEN STRING ; DAS AND IENS MUST BE AVAILABLE TO ALL ITERATORS + S OREF=$$ROOT^DILFD(FIEN,IENS) I '$L(OREF) S ERR="Unable to generate a vaild open reference" D ERR^BMXADO(ERR) Q + S CREF=$$CREF^DILF(OREF) I '$L(CREF) S ERR="Unable to generate a vaild closed reference" D ERR^BMXADO(ERR) Q +DATA ; GET DATA +SPEC I $L(EP) D Q ; SPECIAL CASE: USE CUSTOM ITERATOR + . I '$G(LDA) S LDA="" + . X ("S LDA=$$"_EP_"(PARAM,IENS,MAX,.OUT,.TOT)") + . D SEED(LDA) + . Q + I IX="" S LDA=$$NUMIT^BMXADOV1(+$G(DA)) D SEED(LDA) Q ; NO INDEX USED: ITERATE IN IEN ORDER + I IX="AA",FIEN=9000013!(FIEN=9000019) S IX="AC" ; 'AA' ITERATION UNNECESSARY FOR SOME FILES. BETTER TO USE 'AC' + I '$L($O(@CREF@(IX,""))) Q ; NO INDEXED DATA AVAILABLE, SO QUIT NOW + I IX="AA" D Q ; SPECIAL CASE: AA INDEX + . I FIEN=9000011 S LDA=$$AAP^BMXADOV1 Q ; THE AA INDEX FOR 'PROBLEMS'; LDA ALWAYS NULL + . S LDA=$$AA^BMXADOV1 D SEED(LDA) ; THE VISIT/V-FILE AA INDEX + . Q + S FINFO=$$IXFLD(FIEN,IX) I FINFO="" Q ; FILE INFO: IX FIELD NUMBER, TYPE, AND DINUM SUBTYPE + I $P(FINFO,U,2)="D" D ; PREP FOR DATE INDEX LOOKUP + . I $L(START) S X=START D ^%DT S START=+Y + . I $L(STOP) S X=STOP D ^%DT S STOP=+Y + . Q + I $P(FINFO,U,2)="P",$E(START)="`" D Q ; SPECIAL CASE: SHORTCUT TO POINTER LOOKUP FOR A SINGLE, SPECIFIC IEN. + . S LIEN=+$E(START,2,99) + . S LDA=$$LOOK^BMXADOV1(LIEN) + . D SEED(LDA) + . Q + I $P(FINFO,U,4) S LFILE=$P(FINFO,U,3) I LFILE D Q ; SPECIAL CASE: DINUM -> TEXT LOOKUP. + . S LDA=$$LOOK2^BMXADOV1(LFILE) + . D SEED(LDA) + . Q + S LDA=$$LOOK1^BMXADOV1 ; STD INDEX LOOKUP: START FROM SCRATCH + D SEED(LDA) ; CAPTURE RE-ENTRY SEED + Q + ; +SEED(LDA) ; UPDATE THE SCHEMA STRING WITH THE SEED PARAMETER + N X,Y + S X=@OUT@(1) + S Y=$P(X,U) + S $P(Y,"|",3)=LDA + S $P(X,U,1)=Y + S @OUT@(1)=X + Q + ; +IENS(DAS) ;EP - CONVERT DAS STRING TO IENS STRING + N I,L,IENS + S DAS=$G(DAS) + S DAS=$TR(DAS,"+","") + S DAS=$TR(DAS,"-","") + I '$L(DAS) Q "," + I DAS="," S DAS="" + S L=$L(DAS,C) + S IENS="" + F I=L:-1:1 S IENS=IENS_$P(DAS,C,I)_C + Q IENS + ; +IXFLD(FIEN,IX) ;EP - GIVEN AN FILE NUMMER AND INDEX NAME, RETURIN THE FIELD NUMBER, TYPE, AND DINUM SUBTYPE + N FLD,TYPES,T,X,I + I '$G(FIEN) Q "" + I '$L($G(IX)) Q "" + S FLD=$O(^DD(FIEN,0,"IX",IX,FIEN,0)) + I 'FLD Q FLD + S TYPES="DNSFWCPVM",T=$P($G(^DD(FIEN,FLD,0)),U,2) + F I=1:1 S X=$E(TYPES,I) Q:'$L(X) I T[X Q + I X="P" S X=X_U_+$P(T,"P",2) I $P(^DD(FIEN,FLD,0),U,5)["DINUM" S X=X_U_1 + S FLD=FLD_U_X + Q FLD + ; Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOV1.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOV1.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOV1.m (revision 1147) @@ -0,0 +1,229 @@ +BMXADOV1 ; IHS/CIHA/GIS - RPC CALL: GENERATE DATA FOR AN ADO DATASET ; + ;;4.1000;BMX;;Apr 17, 2011 + ; CONTINUATION FILE FOR BMXADOV + ; MANAGES ITERATION FOR INDIVIDUAL INDEX TYPES + ; ASSUMES CERTAIN LOCAL VARS: CREF,FIEN,IENS,DAS (<-THESE CAN'T BE NULL),START,STOP,MAX,TOT,NUM,IX + ; + ; + ; +DATA(IENS,DA,XCNT) ;EP - ADD DATA NODES TO ARRAY + ; ASSUMES THAT VSTG VARIABLES AND THE OUT ARRAY ARE PRESENT + I '$G(DA) Q + I '$L(IENS) Q + S $P(IENS,C)=DA + N STG,X,Y,%,FLD,STOP,VAL,CNT,FIEN,LINE,IFLAG,IDEP,TFLD,TNO,TEF + S STG=DA + I $G(DAS),$E(DAS,$L(DAS))="," S STG=$TR(DAS,",",U)_STG ; FIX FOR SUBFILE + S CNT=$L(IENS,",") ; START AFTER THE .001 FIELD + I $G(SUB) S STG=$P(IENS,C,2)_U_DA ; MAKE DAS FOR A SUBFILE. THIS WILL BE THE IST PIECE OF THE DATA STRING + I $G(XCNT) S CNT=XCNT ; USED WITH JOINS + F S CNT=$O(@OUT@(CNT)) Q:'CNT Q:$G(STOP) D I @OUT@(CNT)[$C(30) Q ; LOOP TO CREATE THE DATA STRING + . K IFLAG,IDEP + . S FIEN=+@OUT@(CNT) I '$D(^DD(FIEN,0)) S STOP=1 Q + . S FLD=$P(@OUT@(CNT),B,2) + . I FLD=".01ID" D Q ; PROCESS THE IDENTIFIER FIELD + .. I '$G(SIEN) Q + .. S %=$O(^BMXADO(SIEN,1,"B",".01ID",0)) I '% Q + .. S IDEP=$G(^BMXADO(SIEN,1,%,1)) I '$L(IDEP) Q + .. X ("S VAL=$$"_IDEP_"("_+STG_")") ; PASS THE DA TO THE IDENTIFIER EXTRINSIC FUNCTION, RETURN IDENTIFIERS + .. S VAL=$TR(VAL,"^",""),VAL=$TR(VAL,B,"") + .. S STG=STG_U_VAL + .. Q + . I $G(SIEN),FLD S %=$O(^BMXADO(SIEN,1,"B",FLD,0)) I %,$P($G(^BMXADO(SIEN,1,%,0)),U,9) S IFLAG=1 ; SCHEMA FILE SAYS FORCE INTERNAL VALUE FOR THIS FIELD + . K TFLD + . I FLD["TRIGGER" S TFLD=FLD,FLD=+FLD,IFLAG=1 + . I FLD["IEN" S FLD=+FLD,IFLAG=1 ; LOOKUP VALUE FIELD (IEN) + . I '$D(^DD(FIEN,FLD,0)),FLD'=.001 S STOP=1 Q + . I $D(TFLD),FLD=.001 S VAL=+IENS + . E S VAL=$$GET1^DIQ(FIEN,IENS,FLD,$S($G(IFLAG):"I",$G(TFLAG):"I",1:$G(FMT))) + . I $G(TFLD) D S STG=STG_U_VAL Q ; GENERATE A TRIGGERED VALUE FOR THIS FIELD + .. S TNO=$O(^BMXADO(SIEN,1,"B",TFLD,0)) I 'TNO S VAL="" Q + .. S TEF=$G(^BMXADO(SIEN,1,TNO,3)) I '$L(TEF) S VAL="" Q ; GET EXTR FUNCT THAT GENERATES A SECONDARY VALUE + .. X ("S VAL=$$"_TEF_"(VAL)") + .. Q + . I FLD=.01,VAL="" S STOP=1 Q ; INVALID FILEMAN ENTRY! SKIP IT + . S VAL=$TR(VAL,"^",""),VAL=$TR(VAL,B,"") + . S STG=STG_U_VAL + . Q + I $G(STOP) Q ; DON'T ADD NODE IF DD INFO IS INVALID + F S LINE=$E(STG,1,250),STG=$E(STG,251,999999) D I '$L(STG) Q ; PREVENTS DATA LENGTH FROM EXCEEDING 250 BYTES + . S TOT=TOT+1 + . I '$L(STG) S LINE=LINE_$C(30),NUM=NUM+1 ; END OF RECORD, RECORD TOTAL IS UPDATED + . S @OUT@(TOT)=LINE ; NODE IS ADDED + . Q + Q + ; +NUMIT(DA) ; EP-ITERATE BY NUMBER + N XIT,LDA + I IENS S DA=+IENS ; RE-ENTRY FROM SEED + I '$G(DA),$G(START) S DA=START-1 + I '$G(DA) S DA=0 + S LDA="" + F S DA=$O(@CREF@(DA)) D I $G(XIT) Q + . I 'DA S XIT=1,LDA="" Q ; NO MORE IENS - THE END OF THE LINE + . D DATA(IENS,DA,+$G(XCNT)) + . I $G(STOP),$O(@CREF@(DA))>STOP S LDA="",XIT=1 Q ; AS FAR AS YOU ARE ALLOWED TO GO FOR NUMBER ITERATION + . I NUM=MAX S LDA=DA,XIT=1 Q ; REACHED THE MAX TRANSACTION LIMIT - GET MORE NEXT TIME + . Q + I LDA,'$O(@CREF@(LDA)) S LDA="" ; END OF THE LINE SO SET LDA TO NULL + Q LDA + ; +LOOK(LIEN) ; EP-ITERATE BY A SINGLE STANDARD INDEX THAT IS A POINTER VALUE + N XIT,LDA + S DA=+IENS + F S DA=$O(@CREF@(IX,LIEN,DA)) D I $G(XIT) Q + . I 'DA S XIT=1,LDA="" Q ; NO MORE IENS - THE END OF THE LINE + . D DATA(IENS,DA,$G(XCNT)) + . I NUM=MAX S LDA=DA,XIT=1 Q ; REACHED THE MAX TRANSACTION LIMIT - GET MORE NEXT TIME + . Q + I '$O(@CREF@(IX,LIEN,DA)) Q "" + Q LDA + ; +LOOK1() ; EP-ITERATE USING A STANDARD INDEX + N XIT,LDA,VAL,DA,% + S DA=+IENS I 'DA G SCRATCH ; CHECK FOR RE-RENTRY +REENTER ; RE-ENTER STD ITERATION USING DA AS THE SEED + S %=$$IXVAL(FIEN,IX,DAS) I '$L(%) Q "" ; GET STARTUP INFO +LR S VAL=$P(%,B,3) + I VAL="" Q "" ; NO VAL FOUND FOR INITIAL ITERATION, SO QUIT + F S DA=$O(@CREF@(IX,VAL,DA)) Q:'DA D DATA(IENS,DA,+$G(XCNT)) I NUM=MAX S LDA=DA,XIT=1 Q ; SWEEP UP ALL THE REMAINING DAS UNDER THE CURRENT VALUE + I $G(XIT) Q:'$O(@CREF@(IX,VAL,LDA)) "" Q LDA ; IF NO MORE AFTER MAX, SET LDA = NULL + G LOOK1R ; SEED IS DEFINED +SCRATCH S VAL="" ; STD LOOKUP STARTING FROM SCRATCH + I $L(START) S VAL=$O(@CREF@(IX,START),-1) ; GET SEED FOR ITERATION +LOOK1R F S VAL=$O(@CREF@(IX,VAL)) D I $G(XIT) Q ; EP - RE-ENTRY POINT IF SEED IS DEFINED + . I VAL="" S LDA="",XIT=1 Q ; END OF THE LINE + . I STOP=+STOP,VAL=+VAL,VAL>STOP S LDA="",XIT=1 Q + . I $L(STOP),VAL]STOP S LDA="",XIT=1 Q ; LOOKUP LIMITS + . S DA=0 + . F S DA=$O(@CREF@(IX,VAL,DA)) Q:'DA D I $G(XIT) Q + .. D DATA(IENS,DA,+$G(XCNT)) + .. I NUM=MAX S LDA=DA,XIT=1 D ; TRANSACTION LIMIT ; CHECK FOR MORE + ... I $O(@CREF@(IX,VAL,DA)) Q + ... S %=$O(@CREF@(IX,VAL)) I %="" S LDA="" Q + ... I $L(STOP),%]STOP S LDA="" Q + ... I '$O(@CREF@(IX,%,0)) S LDA="" Q + ... Q + .. Q + . Q + Q LDA + ; +LOOK2(LFILE) ; EP-TEXT POINTER LOOKUP + ; CHANGE THE GLOBAL REFERENCE FOR THE LOOKUP TO THE POINTED-TO FILE BEFORE PROCEEDING + N XIT,LDA,OREF,CREF,VAL,DA + S OREF=$$ROOT^DILFD(LFILE,IENS) I '$L(OREF) Q "" + S CREF=$$CREF^DILF(OREF) I '$L(CREF) Q "" + S DA=+IENS + I '$G(DA) G SCRATCH ; START FROM SCRATCH + S %=$$IXVAL(LFILE,IX,DAS) I '$L(%) Q "" + G LR ; RE-ENTER + ; +IXVAL(FIEN,IX,DAS) ; GIVEN A FILE IEN, INDEX NAME, AND DAS STRING, RETURN THE VALUE USED IN THE INDEX + N DA,FLD,IENS,OREF,CREF,XREF,VAL,UP,LEV,L + I '$D(^DD(+$G(FIEN),0)) Q "" ; MISSING OR INVALID FILE NUMBER + I '$L($G(IX)) Q "" ; NO INDEX SPECIFIED + S UP=FIEN F LEV=1:1 S UP=$G(^DD(UP,0,"UP")) Q:'UP + I LEV'=$L(DAS,C) Q "" ; DAS LEVELS MUST MATCH FILE OR SUBFILE LEVEL + S IENS=$$IENS^BMXADOV($G(DAS)) I IENS=U Q "" + S OREF=$$ROOT^DILFD(FIEN,IENS) I '$L(OREF) Q "" + S CREF=$$CREF^DILF(OREF) I '$L(CREF) Q "" + I '$D(@CREF@(IX)) Q CREF_"||" ; NO INDEX VALUES TO CHECK + S XREF=OREF_IX_")" + S DA=+IENS I 'DA Q CREF_"||" + I '$D(@CREF@(DA)) Q CREF_"||" ; NO ENTRY EXISTS + I IX="AA" G AA + S FLD=+$$IXFLD^BMXADOV(FIEN,IX) I 'FLD Q "" ; INVALID DD + S VAL=$$GET1^DIQ(FIEN,IENS,FLD,"I") I VAL="" Q "" ; VALUE IS NULL - NOTHING TO INDEX + I '$D(@CREF@(IX,VAL,DA)) Q "" ; INVALID INDEX + Q XREF_B_DA_B_VAL + ; +AA() ;EP - VISIT/V-FILE ITERATION USING THE 'AA' INDEX + N LDA,XIT,AAINFO,DA,%,X,Y,DFN,TYPE,ORD,ISTART,ISTOP,IDT,AAREF,%DT,DIC + S X=OREF_"""AA"")",%=$Q(@X) I %="" Q "" + S TYPE="" I $L(%,C)=5 S TYPE=$P(PARAM,B,2) I TYPE="" Q "" ; FOR CERTAIN V FILES, TYPE MUST BE DEFINED + I $E(TYPE)="`" S TYPE=$E(TYPE,2,99) I 'TYPE Q "" ; REMOVE ` FROM TYPE IEN + I $L(TYPE),'TYPE D I TYPE'>0 Q "" ; QUIT IF INVALID TYPE + . S %=$P($G(^DD(FIEN,.01,0)),U,2) + . S DIC=+$P(%,"P",2) I '$D(^DD(DIC,.01,0)) Q + . S X=TYPE,DIC(0)="M" D ^DIC I Y=-1 Q + . S TYPE=+Y + . Q + S DFN=+PARAM + I '$D(^DPT(DFN,0)) Q "" ; PATIENT DFN MUST BE DEFINED + I 'TYPE S AAREF=OREF_"""AA"","_DFN_")" + E S AAREF=OREF_"""AA"","_DFN_","_TYPE_")" + I '$D(@AAREF) Q "" ; IF NOTHING UNDER AA INDEX, DON'T BOTHER LOOKING + S ISTART=9999999 I START S X=START,%DT="P" D ^%DT S ISTART=9999999-Y + S ISTOP=0 I STOP S X=STOP,%DT="P" D ^%DT S ISTOP=9999999-Y + S ORD=-1 I $P(PARAM,B,$L(PARAM,B))="R" S ORD=1 ; SORT IN CHRONOLOGICAL OR REVERSE CHRONOLOGICAL ORDER + I ORD=-1 S X=$G(ISTART),Y=$G(ISTOP),ISTOP=X,ISTART=Y ; CHANGES REQUIRED TO PRESENT DATA IN CHRONOLIGICAL ORDER + S IDT=0,LDA="" + I ISTOP S IDT=ISTOP-.0000001 + S DA=+IENS + I DA S IDT=$$AAR I 'IDT Q LDA ; SWEEP UP REMAINING IENS FOR CURRENT IDT AND RESET IDT FOR RE-ENTRY + F S IDT=$O(@AAREF@(IDT),ORD) Q:'IDT D I $G(XIT) Q + . I ORD=1,IDT>ISTART S LDA="",XIT=1 Q + . I ORD=-1,IDTDATE S DATE=+X,MAX=DA + . Q + I 'MAX Q "" + S DA=MAX + D DATA^BMXADOV1(IENS,DA) + Q "" + ; +MCDIEN(DFN) ; EP-GIVEN A PATIENT IEN, RETRUN THE IEN OF THAT PT'S MOST RECENT RECORD IN MEDICAID ELIGIBILITY FILE + N MIEN,DA,DATE,MAX,X + S DFN=+$G(DFN),MAX="",DATE=0 + S MIEN=0 F S MIEN=$O(^AUPNMCD("B",DFN,MIEN)) Q:'MIEN D + . S DA=0 F S DA=$O(^AUPNMCD(MIEN,11,DA)) Q:'DA D + .. S X=+$P($G(^AUPNMCD(MIEN,11,DA,0)),U,2) + .. I X>DATE S DATE=X,MAX=MIEN + .. Q + . Q + Q MAX + ; +MEDICAID(PARAM,IENS,MAX,OUT,TOT) ; + ; NO PARAM REQUIRED BUT SINCE THIS IS A SUBFILE, THE PATIENT IEN MUST BE IH IENS + ; FETCHES THE MOST RECENT MEDICARE RECORD FOR THE PATIENT + N MIEN,DA,X,Y,%,LIM,DATE,MAX + S LIM=DT-10000,DA=0,DATE=0,MAX=0 + S MIEN=$P(IENS,C,2) I 'MIEN Q "" + F S DA=$O(^AUPNMCD(MIEN,11,DA)) Q:'DA D + . S X=$G(^AUPNMCD(MIEN,11,DA,0)) + . I +X>DATE S DATE=+X,MAX=DA + . Q + I 'MAX Q "" + S DA=MAX + D DATA^BMXADOV1(IENS,DA) + Q "" + ; +PT(VAL,IENS,MAX,OUT,TOT) ; EP - PATIENT LOOKUP ; GIVEN A LOOKUP VALUE, GENERATE A LIST OF PATIENTS + N DFN,BMXNOID,DA,X,Y,%,LIM,FILE,NUM,IXS,GBL,CNT,SS + I $G(VAL)="" Q "" + S BMXNOID=1 + I '$G(MAX) S MAX=999 + I $G(^DD("2","0","ID","IHS0"))="D ^AUPNLKID" S ^("IHS0")="D:'$G(BMXNOID) ^AUPNLKID" ; MUST BE A SILENT CALL + S SS="BMX DFN2",GBL=$NA(^TMP(SS,$J)) K @GBL + S CNT=0,DFN=0 + F S DFN=$O(^AUPNPAT("D",VAL,DFN)) Q:'DFN S CNT=CNT+1 S @GBL@("DILIST",2,CNT)=DFN ; FIRST, TRY TO MATCH CHART NUMBER + I CNT G PTIT + I VAL?3N1"-"2N1"-"4N S VAL=$TR(VAL,"-","") ; TRANSFORM SSN + I VAL?9N G PT1 + S %=$L(VAL),X=$E(VAL,%-1,%) + I X?2N S X=VAL,%DT="P" D ^%DT S VAL=Y ; TRANSFORM DATE TO INTERNAL VALUE +PT1 K @GBL S SS="BMX DFN1",GBL=$NA(^TMP(SS,$J)) K @GBL + D FIND^DIC(2,"","","",VAL,999,"B^ADOB^SSN","","",GBL,"") + I '$D(^TMP(SS,$J,"DILIST",2)) Q "" ; UNSUCCESSFUL LOOKUP +PTIT ; ITERATE + S CNT=0,NUM=0 + F S CNT=$O(^TMP(SS,$J,"DILIST",2,CNT)) Q:'CNT S DA=^(CNT) I DA D DATA^BMXADOV1(IENS,DA) + I $G(^DD("2","0","ID","IHS0"))="D:'$G(BMXNOID) ^AUPNLKID" S ^("IHS0")="D ^AUPNLKID" ; RESTORE DD NODE + ; K @GBL ; CLEANUP + Q "" + ; +HRN(DFN) ; EP - GIVEN A PATIENT DFN, RETURN THE LOCAL CHART NUMBER + Q $P($G(^AUPNPAT(+$G(DFN),41,+$G(DUZ(2)),0)),U,2) + ; +PVTINS ; + ; NO PARAM REQUIRED BUT SINCE THIS IS A SUBFILE, THE PATIENT IEN MUST BE IH IENS + N DFN,DA,X,Y,%,LIM + S LIM=DT-10000,DA=0 + S DFN=$P(IENS,C,2) I 'DFN Q "" + F S DA=$O(^AUPNPRVT(DFN,11,DA)) Q:'DA D + . S X=$G(^AUPNPRVT(DFN,11,DA,0)) + . I '$L(X) Q + . S %=$P(X,U,7) + . I '%!(%>LIM) D DATA^BMXADOV1(IENS,DA) + . Q + Q "" + ; +DUPV(PARAM,IENS,MAX,OUT,TOT) ; EP - DUPLICATE VISIT ITERATION + ; PARAM: 'DFN|VISIT TIMESTAMP|TYPE|LOCATION|CATEGORY + ; PATIENT DFN AND VISIT TIMESTAMP (EXTERNAL DATE FORMAT) MUST EXIST. + ; THE OTHER 3 DUP PARAMETERS WILL BE CHECKED ONLY IF THEY ARE DEFINED. + ; ALL DUPS ARE RETURNED. MAX,START,STOP ARE IGNORED + N DFN,TIME,TYPE,LOC,CAT,IDT,VIEN,DAY,X,PATIENT,Y,%DT,FMTIME,DA,IENS + S DFN=+PARAM,TIME=$P(PARAM,B,2),TYPE=$P(PARAM,B,3),LOC=$P(PARAM,B,4),CAT=$P(PARAM,B,5) + I $D(^DPT(+$G(DFN),0)),$L($G(TIME)) + E Q "" + S X=TIME,%DT="T" D ^%DT I Y=-1 Q + S FMTIME=Y + S (IDT,DAY)=9999999-(FMTIME\1),IDT=IDT-.0000001 + F S IDT=$O(^AUPNVSIT("AA",DFN,IDT)) Q:$E(IDT,1,7)'=DAY S VIEN=999999999999 F S VIEN=$O(^AUPNVSIT("AA",DFN,IDT,VIEN),-1) Q:'VIEN D + . S X=$G(^AUPNVSIT(VIEN,0)) I '$L(X) Q ; VISIT DATA MUST EXIT + . I $P(X,U,11) Q ; MUST BE AN 'ACTIVE' VISIT - NOT 'DELETED' + . I $L(TYPE),TYPE'=$P(X,U,3) Q + . I $L(LOC),LOC'=$P(X,U,6) Q + . I $L(CAT),CAT'=$P(X,U,7) Q + . S DA=VIEN,IENS=DA_C + . D DATA^BMXADOV1(IENS,DA) + . Q + Q "" + ; +DAIT(DSTG,IENS,MAX,OUT,TOT) ; EP - SET OF IENS ITERATION. + ; THE DSTG CONTAINS A "|" SET OF DAS STRINGS + ; ALL VALUES ARE RETURNED. MAX IS NOT CHECKED. START AND STOP ARE IRRELEVANT + N PCE,DA,XIT,IENS,L,DAS + S L=$L(DSTG,B) + F PCE=1:1:L S DAS=$P(DSTG,B,PCE) D I $G(XIT) Q + . I 'DAS S XIT=1 Q ; NO MORE IENS - THE END OF THE LINE + . I DAS'[C S IENS=DAS_C + . E S IENS=$$IENS^BMXADOV(DAS) + . S DA=+IENS + . D DATA^BMXADOV1(IENS,DA) + . Q + Q "" + ; +APRV(PARAM,IENS,MAX,OUT,TOT) ; EP - RETURN A LIST OF ALL ACTIVE PROVIDERS + ; ALL VALUES ARE RETURNED. MAX IS NOT CHECKED. START AND STOP ARE IRRELEVANT + N NAME,DA,STG + S NAME="" + F S NAME=$O(^VA(200,"B",NAME)) Q:NAME="" D + . S DA=0 + . F S DA=$O(^VA(200,"B",NAME,DA)) Q:'DA D + .. I $P($G(^VA(200,DA,"PS")),U,4) Q ; CHECK INACTIVE DATE FIELD + .. D DATA^BMXADOV1(IENS,DA) + .. Q + . Q + Q "" + ; Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOVJ.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOVJ.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOVJ.m (revision 1147) @@ -0,0 +1,78 @@ +BMXADOVJ ; IHS/CIHA/GIS - RPC CALL: GENERATE DATA FOR AN ADO DATASET ; + ;;4.1000;BMX;;Apr 17, 2011 + ; THIS ROUTINE MANAGES THE JOINS + ; + ; + ; + ; THE FIFTH PARAMETER OF SS^BMXADO CONTAINS THE JOIN INSTRUCTIONS + ; SYNTAX: DESCENDANT SCHEMA IEN (DETAILS FILE), JOIN FIELD FROM MASTER FILE + ; THE FIRST "," PIECE STATES THAT THE MASTER FILE IS JOINED BY ITS .02 FIELD TO THE DETAILS FILE + ; THE SECOND "," PIECE STARTES THAT THE DETAILS FILE IS DEFINED BY SCHEMA #6 + ; AN OPTIONAL 3RD "," PIECE MAY CONTAIN A SECONDARY VSTG TO MORE PRECISELY DEFINE JOIN ITERATION + ; E.G., "...~6.,.02,AA~1/1/2004~2/1/2004~~~~~|WT|R" + ; IN THIS CASE, THE SECONDARY VSTG SPECIFIES THAT THE AA INDEX BE USED TO CONTROL THE ITERATOR + ; THE START AND STOP DATES ARE IN EFFECT BUT MAX IS IGNORED/IRRELEVANT + ; THE 1ST "|" PIECE OF THE PARAM SECTION WILL BE AUTOMATICALLY STUFFED WITH PATEINT DFN(S) DURING ITERATION + ; IF MULTIPLE JOINS ARE REQUESTED, THEY ARE SPARATED BY THE '@JOIN@' DELIMTER + ; "E.G., 6,.02@JOIN@1,.03@JOIN@2,.02@JOIN@9,SUB" + ; IN THIS EXAPLE THE MASTER FILE IS JOIND TO THE DETAILS FILES ASSOCIATED WITH SCHEMAS 6, 1, AND 9 + ; NOTE THAT THE 3RD JOIN DEINED IN THE STRING SPECIFIES A SUBFILE REALTION RATHER THAN A "POINTER" RELATION + ; IF A SECOND RECORD SET IS CREATED TO FULFILL A JOIN REQUEST, IT WILL ONLY CONTAIN THE ROWS NECESSARY TO COMPLETE THE JOIN + ; +JOIN(SMASTER,JSTG) ;EP - APPEND ADDITIONAL ANRS TO FULFILL JOIN REQUESTS + N TMP,JOIN,JINST,FMASTER + I '$L($G(JSTG)) Q ; JOIN STRING MUST NOT BE NULL + S FMASTER=$P($G(^BMXADO(+$G(SMASTER),0)),U,2) I 'FMASTER Q ; MASTER SCHEMA & FILE MUST EXIST + S TMP=$NA(^TMP("BMX JOIN",$J)) K @TMP ; JOIN INFO TEMP STORAGE ARRAY + S @TMP@(0,SMASTER)=$$RANGE ; GET DATA NODE RANGE FOR THE MASTER ANR + I '$D(@TMP@(0)) Q ; DATA MUST EXIST IN THE MASTER FILE OR QUIT + F JOIN=1:1 S JINST=$P(JSTG,"@JOIN@",JOIN) Q:JINST="" D J(SMASTER,JINST) ; MAIN LOOP FOR DOING JOINS + K @TMP + Q + ; +RANGE() ; GET DATA NODE RANGE FOR LAST SCHEMA ENTERED + N X,FIRST,LAST,Y + S (X,LAST)=$O(@OUT@(999999999),-1) + F S X=$O(@OUT@(X),-1) Q:'X S Y=@OUT@(X) Q:Y'[$C(30) S FIRST=X + I '$G(FIRST) Q "" + S FIRST=FIRST+1 + Q (FIRST_U_LAST) + ; +J(SMASTER,JSTG) ; JOIN DETAILS FILE TO MASTER FILE + ; SMASTER=MASTER SCHMA IEN, SDETAIL=DETAILS SCHEMA IEN + N JARR,SEC,ERR,JIEN,SUB,IX,PARENT,JFLD,DFLD,NODE,X,STOP,VSTG2,SDETAIL,JFLD + S SDETAIL=$P(JSTG,C),JFLD=$P(JSTG,C,2),DFLD=$P(JSTG,C,3),VSTG2=$P(JSTG,C,4,999) + I JFLD="SUB" S JFLD=.001,DFLD=.0001 + I JFLD=.001,DFLD=.0001 S SUB=1,VSTG2="~~~~~SIT~BMXADOVJ~" ; MAKE SUBFILE ITERATOR VSTG + D IEN(SMASTER,SDETAIL,JFLD) ; GET A LIST OF JOIN IENS FROM THE MASTER FILE + I '$D(@TMP@(1)) Q ; NO MASTER FILE IENS FOR JOINS, SO QUIT + N FIEN,DAS,SIEN,VSTG,JSTG + S DAS="",SIEN=SDETAIL,VSTG=VSTG2 + S FIEN=$P($G(^BMXADO(SIEN,0)),U,2) I 'FIEN Q + D JEP^BMXADO ; BUILD THE JOIN ANR + Q + ; +IEN(SMASTER,SDETAIL,JFLD) ; GET THE MASTER FILE IENS FOR BUILDING THE JOIN DATA SET + N FIEN,%,FIRST,LAST,NODE,DA,IEN + I JFLD["IEN" S JFLD=+JFLD + S FIEN=$P($G(^BMXADO(SMASTER,0)),U,2) I 'FIEN Q + S %=$G(@TMP@(0,SMASTER)) I '$L(%) Q + S FIRST=+%,LAST=$P(%,U,2),NODE=FIRST-.1 + F S NODE=$O(@OUT@(NODE)) Q:'NODE Q:NODE>LAST D + . S DA=+@OUT@(NODE) + . I 'DA Q + . I JFLD=.001 S @TMP@(1,SDETAIL,DA)="" Q + . S IEN=$$GET1^DIQ(FIEN,(DA_C),JFLD,"I") I 'IEN Q + . S @TMP@(1,SDETAIL,IEN)="" + . Q + Q + ; +JFLD ; EP-STUFF JOIN FIELD IDS INTO THE INTRO SEGMENT OF THE SCHEMA + N NODE,% + S NODE=999999999999 + F S NODE=$O(@OUT@(NODE),-1) Q:'NODE I @OUT@(NODE)["@@@meta@@@" Q + I 'NODE Q + S %=$P(@OUT@(NODE),U),$P(%,"|",4)=$G(JFLD),$P(%,"|",5)=$G(DFLD) + S @OUT@(NODE)=%_U + Q + ; Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOX.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOX.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOX.m (revision 1147) @@ -0,0 +1,501 @@ +BMXADOX ; IHS/CIHA/GIS - RPC CALL: GENERATE AN ADO SCHEMA STRING AND DATA SET ; + ;;4.1000;BMX;;Apr 17, 2011;Build 13 + ; EXMAPLES OF RPMS SCHEMAE GENERATION + ; + ; +DISP(OUT) ;EP - TEMP DISPLAY + N I,X + S I=0 W ! + F S I=$O(@OUT@(I)) Q:'I S X=@OUT@(I) S X=$TR(X,$C(30),"}") S X=$TR(X,$C(31),"{") W !,X + Q + ; +SCHEMA(NAME) ; GIVEN SCHEMA NAME, RETURN THE IEN + N IEN + S IEN=$O(^BMXADO("B",NAME,0)) + Q IEN + ; +NEXTNUM(DFN,LOC) ; RETURN THE NEXT PROBLEM NUMBER FOR A PATIENT + N X,LAST,MAX,NUM + S NUM=0,MAX="" + F S NUM=$O(^AUPNPROB("AA",DFN,LOC,NUM)) Q:NUM="" S X=$E(NUM,2,99) I +X>MAX S MAX=+X + I 'MAX Q 1 + S X=X+1 S X=X\1 + Q X + ; +DEMOG ; VIEW DEMOGRAPHICS + N OUT,%,DFN,MAX,SIEN + S DFN=1,MAX=1000 + S SIEN=$$SCHEMA("UPDATE PATIENT DEMOGRAPHICS") + D SS^BMXADO(.OUT,SIEN,"",("~"_DFN_"~"_DFN_"~"_MAX)) + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +MEDICARE ; UPDATE MEDICARE DATES/INFO + N OUT,%,DAS,PIEN,JIEN,DFN,MAX + S DFN=1,MAX=1000 + S DAS=DFN_"," + S PIEN=$$SCHEMA("UPDATE MEDICARE DATES") + S JIEN=$$SCHEMA("UPDATE MEDICARE INFO") + D SS^BMXADO(.OUT,PIEN,DAS,("~"_DFN_"~"_DFN_"~"_MAX_"~~"_"MEDICARE~BMXADOV2~~"_JIEN_",PARENT")) + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +MEDICAID ; VIEW MEDICAID DATES/INFO + N OUT,%,DAS,PIEN,JIEN,DFN,DA + S DFN=3 + S DA(1)=$$MCDIEN^BMXADOV2(DFN) I 'DA(1) Q + S DAS=DA(1)_"," + S PIEN=$$SCHEMA("UPDATE MEDICAID DATES") + S JIEN=$$SCHEMA("UPDATE MEDICAID INFO") + D SS^BMXADO(.OUT,PIEN,DAS,("~~~~~MEDICAID~BMXADOV2~~"_JIEN_",PARENT")) + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +PVTINS ; VIEW PRIVATE INSURANCE DATES/INFO + N OUT,%,DAS,SIEN,DFN + S DFN=1 + S DAS=DFN_"," + S SIEN=$$SCHEMA("UPDATE PVT INSURANCE INFO") + D SS^BMXADO(.OUT,SIEN,DAS,"~~~~~PVTINS~BMXADOV2~~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +VISIT ; VIEW VISITS + N OUT,%,SIEN,DFN + S DFN=1 + S SIEN=$$SCHEMA("VISITS") + D SS^BMXADO(.OUT,SIEN,"","AA~3/21/1985~6/4/1986~100~~~~1|R") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +DUPVIS ; DISPLAY POSSIBLE DUPLICATE VISITS + N OUT,%,SIEN,DFN + S DFN=1 + S SIEN=$$SCHEMA("VISITS") + D SS^BMXADO(.OUT,SIEN,"","~~~~~DUPV~BMXADOV2~1|4/19/04@1PM|I|4585|A~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDVIS ; ADD A NEW VISIT + N OUT,%,SIEN,DFN,NODE + S DFN=3 + S SIEN=$$SCHEMA("VISITS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^JUN 03, 2004@09:32^I^`3^`4585^A^`1"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +POV ; DISPLAY POVS + N OUT,%,SIEN,DFN + S DFN=1 + S SIEN=$$SCHEMA("VIEW POVS") + D SS^BMXADO(.OUT,SIEN,"","AA~3/21/1985~6/4/1986~100~~~~1|C") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +FLDS ; GET FILEMAN FIELDS + N OUT,%,SIEN,DFN + S SIEN=$$SCHEMA("FIELDS") + D SS^BMXADO(.OUT,SIEN,"","~~~~~FLDIT~BMXADOS1~3.7~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +FINFO ; GET FILEMAN FILEINFO + N OUT,%,SIEN,DFN + S SIEN=$$SCHEMA("FILEMAN FILEINFO") + D SS^BMXADO(.OUT,SIEN,"","~~~~~FNIT~BMXADOS1~3.7~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDPOV ; ADD A POV TO AN EXISITING VISIT + N OUT,%,SIEN,DFN,NODE + S DFN=1 + S SIEN=$$SCHEMA("UPDATE POVS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`8718^`1^`71164^DM II ON NEW MEDS^2^P"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +EDITPOV ; ADD A POV TO AN EXISITING VISIT + N OUT,%,SIEN,DFN,NODE + S DFN=1 + S SIEN=$$SCHEMA("UPDATE POVS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="100123^`8718^`1^`71164^DM II ON SPECIAL MEDS^2^P"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +PROB ; DISPLAY PROBLEMS + N OUT,%,SIEN,DFN + S DFN=1 + S SIEN=$$SCHEMA("VIEW PROBLEMS") + D SS^BMXADO(.OUT,SIEN,"","AA~"_DFN_"~"_DFN_"~~~~~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDPROB ; ADD A PROBLEM TO THE PROBLEM LIST + N OUT,%,SIEN,DFN,NODE,NUM,LOC,ICD,TEXT,AIR,IEN + S ICD=2477 + S TEXT="HYPERTENSION ON SPECIAL MEDS" + S DFN=1,LOC=DUZ(2),AIR="A" + S SIEN=$$SCHEMA("UPDATE PROBLEMS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)=U_"`"_ICD_U_"`"_DFN_U_DT_U_U_TEXT_U_"`"_LOC_U_DT_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + S IEN=+$P(OUT(1),"|",2) I '$D(^AUPNPROB(IEN,0)) Q + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + K OUT + S NUM=$$NEXTNUM(DFN,LOC) I 'NUM Q ; PROBLEM NUMBER & STATUS MUST BE ADDED SEPARATELY + S SIEN=$$SCHEMA("UPDATE PROBLEM NUMBER") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)=IEN_U_NUM_U_"A"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +MEAS ; DISPLAY MEASUREMENTS + N OUT,%,SIEN,DFN + S DFN=1 + S SIEN=$$SCHEMA("VIEW MEASUREMENTS") + D SS^BMXADO(.OUT,SIEN,"","AA~3/21/1985~6/4/1986~10~~~~"_DFN_"|WT|C") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDMEAS ; UPDATE V MEASUREMENT FILE + N OUT,%,SIEN,DFN,NODE + S DFN=1 + S SIEN=$$SCHEMA("UPDATE MEASUREMENTS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`2^`"_DFN_"^`71164^177.5^`6"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +MEDS ; DISPLAY MEDS + N OUT,%,SIEN,DFN + S DFN=3 + S SIEN=$$SCHEMA("VIEW MEDS") + D SS^BMXADO(.OUT,SIEN,"","AA~1/1/1989~12/31/1990~10~~~~"_DFN_"|C") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDMEDS ; UPDATE V MED FILE + N OUT,%,SIEN,DFN,NODE + S DFN=3 + S SIEN=$$SCHEMA("UPDATE MEDS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`305^`"_DFN_"^`71164^T1T QID^40"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +LAB ; DISPLAY LAB TEST RESULTS + N OUT,%,SIEN,DFN + S DFN=1 + S SIEN=$$SCHEMA("VIEW LABS") + D SS^BMXADO(.OUT,SIEN,"","AA~1/1/1985~12/31/1987~10~~~~"_DFN_"|175|C") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDLAB ; UPDATE V LAB + N OUT,%,SIEN,DFN,NODE + S DFN=1 + S SIEN=$$SCHEMA("UPDATE LABS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`175^`"_DFN_"^`71164^216"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +EXAMS ; DISPLAY EXAMS + N OUT,%,SIEN,DFN + S DFN=1 + S SIEN=$$SCHEMA("VIEW EXAMS") + D SS^BMXADO(.OUT,SIEN,"","AA~1/1/1986~12/31/1990~10~~~~"_DFN_"|6|C") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDEXAMS ; UPDATE V EXAM + S DFN=1 + S SIEN=$$SCHEMA("UPDATE EXAMS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`6^`"_DFN_"^`71164^NORMAL"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +IMM ; DISPLAY IMMUNIZATIONS + N OUT,%,SIEN,DFN + S DFN=2 + S SIEN=$$SCHEMA("VIEW IMM") + D SS^BMXADO(.OUT,SIEN,"","AA~1/1/1986~12/31/1988~10~~~~"_DFN_"|12|C") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDIMM ; UPDATE V IMMUNIZATION FILE + S DFN=2 + S SIEN=$$SCHEMA("UPDATE IMM") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`12^`"_DFN_"^`71164^2"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +PROV ; DISPLAY PROVIDERS FOR A VISIT + N OUT,%,SIEN,VIEN + S VIEN=11 + S SIEN=$$SCHEMA("VIEW PROV") + D SS^BMXADO(.OUT,SIEN,"","AD~"_VIEN_"~"_VIEN_"~10~~~~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDPROV ; UPDATE V PROVIDER FILE + N OUT,%,SIEN,NODE,PIEN,DFN + S PIEN=5,DFN=1 + I $P(^DD(9000010.06,.01,0),U,3)["DIC(6" S PIEN=$P(^VA(200,PIEN,0),U,16) ; CONVERT FILE 200 TO FILE 16 IF NECESS. + S SIEN=$$SCHEMA("UPDATE PROV") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`"_PIEN_"^`"_DFN_"^`71164^P"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +PROC ; DISPLAY PROCEDURES + N OUT,%,SIEN,DFN + S DFN=4 + S SIEN=$$SCHEMA("VIEW PROCEDURES") + D SS^BMXADO(.OUT,SIEN,"","AA~1/1/1985~12/31/1985~10~~~~"_DFN_"|C") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDPROC ; UPDATE V PROCEDURES FILE + N OUT,%,SIEN,DFN,NODE + S DFN=1 + S SIEN=$$SCHEMA("UPDATE PROCEDURES") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`2198^`"_DFN_"^`71164^`8718"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +CPT ; DISPLAY CPT CODES + N OUT,%,SIEN,DFN + S VIEN=71164 + S SIEN=$$SCHEMA("VIEW CPT") + D SS^BMXADO(.OUT,SIEN,"","AD~"_VIEN_"~"_VIEN_"~10~~~~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDCPT ; UPDATE V CPT FILE + N OUT,%,SIEN,DFN,NODE + S DFN=1 + S SIEN=$$SCHEMA("UPDATE CPT") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`10000^`"_DFN_"^`71164^WOUND CARE"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +PH ; DISPLAY PERSONAL HISTORY + N OUT,%,SIEN,DFN + S DFN=632 + S SIEN=$$SCHEMA("VIEW PERSONAL HISTORY") + D SS^BMXADO(.OUT,SIEN,"","AC~"_DFN_"~"_DFN_"~~~~~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDPH ; UPDATE PERSONAL HX + N OUT,%,SIEN,DFN,NODE,ICD,TEXT + S ICD=2477 + S TEXT="PERSONAL HISTORY OF SERIOUS PROBLEMS" + S DFN=632 + S SIEN=$$SCHEMA("UPDATE PERSONAL HISTORY") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`11353^`"_DFN_"^2851219^"_TEXT_"^2810303"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +FH ; DISPLAY FAMILY HX + N OUT,%,SIEN,DFN + S DFN=631 + S SIEN=$$SCHEMA("VIEW FAMILY HISTORY") + D SS^BMXADO(.OUT,SIEN,"","AC~"_DFN_"~"_DFN_"~~~~~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDFH ; UPDATE FAMILY HISTORY + N OUT,%,SIEN,DFN,NODE,ICD,TEXT + S ICD=2477 + S TEXT="FAMILY HISTORY OF SERIOUS PROBLEMS" + S DFN=631 + S SIEN=$$SCHEMA("UPDATE FAMILY HISTORY") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`7571^`"_DFN_"^2851219^"_TEXT_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +HF ; DISPLAY HEALTH FACTORS + N OUT,%,SIEN,DFN + S DFN=1 + S SIEN=$$SCHEMA("VIEW HEALTH FACTORS") + D SS^BMXADO(.OUT,SIEN,"","AC"_"~"_DFN_"~"_DFN_"~~~~~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDHF ; UPDATE HEALTH FACTORS FILE + N OUT,%,SIEN,DFN,NODE + S DFN=1 + S SIEN=$$SCHEMA("UPDATE HEALTH FACTORS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`3^`"_DFN_U_DT_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +REPRO ; DISPLAY REPRODUCTIVE FACTORS + N OUT,%,SIEN,DFN + S DFN=5 + S SIEN=$$SCHEMA("VIEW REPRODUCTIVE FACTORS") + D SS^BMXADO(.OUT,SIEN,"","B"_"~"_DFN_"~"_DFN_"~~~~~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDREPRO ; UPDATE REPRODUCTIVE FACTORS + ; THE .O1 FIELD IS DINUMED + ; THEREFORE, THE FILER WILL AUTOMATICALLY SWITCH TO MOD MODE IF A RECORD ALREADY EXISTS FOR THIS PATIENT + N OUT,%,SIEN,DFN,NODE + S DFN=5 + ; I $D(^AUPNREP(DFN)) G ERF + S SIEN=$$SCHEMA("ADD REPRODUCTIVE FACTORS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`"_DFN_"^G5P4LC3SA1TA0^"_DT_"^2^3040101^"_DT_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; + ; ---------------------------------- GRIDS --------------------------------------------- + ; +GRID ; POPULATE THE INTRO GRID + N OUT,%,SIEN,NODE,NEXT + S NEXT="70470;0" + S SIEN=$$SCHEMA("VEN MOJO DE INTRO") + D SS^BMXADO(.OUT,SIEN,"","ASEG~"_NEXT_"~"_NEXT) ; GET SCHEMA + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +MGRID ; POPULATE THE MEASUREMENT GRID + N OUT,%,SIEN,NODE,NEXT,START,STOP + S NEXT="70470;2" + S SIEN=$$SCHEMA("VEN MOJO DE MEASUREMENT") + ; D SS^BMXADO(.OUT,SIEN,"","~~~~~GRIDIT~VENPCCTG~"_NEXT) ; GET SCHEMA + D SS^BMXADO(.OUT,SIEN,"","ASEG~"_NEXT_"~"_NEXT) ; GET SCHEMA + D DISP(OUT) R %:$G(DTIME,60) + ; K ^TMP("BMX ADO",$J) + Q + ; +PRVGRID ; POPULATE THE PROVIDER GRID + N OUT,%,SIEN,NODE,NEXT + S NEXT="70470;4" + S SIEN=$$SCHEMA("VEN MOJO DE PROVIDER") + D SS^BMXADO(.OUT,SIEN,"","ASEG~"_NEXT_"~"_NEXT) ; GET SCHEMA + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +CLGRID ; POPULATE THE CLINIC GRID + N OUT,%,SIEN,NODE,NEXT + S NEXT="70470;8" + S SIEN=$$SCHEMA("VEN MOJO DE CLINIC") + D SS^BMXADO(.OUT,SIEN,"","ASEG~"_NEXT_"~"_NEXT) ; GET SCHEMA + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +DXGRID ; POPULATE THE DX GRID + N OUT,%,SIEN,NODE,NEXT + S NEXT="70470;1" + S SIEN=$$SCHEMA("VEN MOJO DE DX DXHX") + D SS^BMXADO(.OUT,SIEN,"","ASEG~"_NEXT_"~"_NEXT) ; GET SCHEMA + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOX1.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOX1.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOX1.m (revision 1147) @@ -0,0 +1,325 @@ +BMXADOX1 ; IHS/CIHA/GIS - RPC CALL: GENERATE AN ADO SCHEMA STRING AND DATA SET ; + ;;4.1000;BMX;;Apr 17, 2011;Build 13 + ; EXMAPLES OF FILEMAN SCHEMA GENERATION + ; + ; + ; N OUT,DAX,% S DAX=0 D SS^BMXADO(.OUT,1,DAX,"^^^5^I^^^^3,XSUB,2160010.03") D DISP(OUT) Q ; TEST EXTENDED SUBJOIN + ; +DISP(OUT) ; + D DISP^BMXADOX(OUT) + Q + ; +SCHEMA(NAME) ; GIVEN SCHEMA NAME, RETURN THE IEN + N IEN + S IEN=$O(^BMXADO("B",NAME,0)) + Q IEN + ; +NUM ; ITERATE BY IEN + ; IX="",START WITH IEN=1, STOP AFTER IEN=20, MAX # RECORDS RETURNED = 5 + ; TO VIEW INTERNAL VALUES SET VSTG="~1~20~5~I" + N OUT,%,SIEN + S SIEN=$$SCHEMA("IHS PATIENT") + D SS^BMXADO(.OUT,SIEN,"","~1~20~5") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +IX ; ITERATE BY INDEX + ; ITERATE USING THE "B" INDEX + ; START WITH PT NAME "C", STOP AFTER PATIENT NAME = "D", MAX # RECORDS RETURNED = 5 + N OUT,%,SIEN + S SIEN=$$SCHEMA("IHS PATIENT") + D SS^BMXADO(.OUT,SIEN,"","B~C~D~5") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +VCN ; SHOW VALUES FOR A SINGLE VISIT THAT AS A DEFINED VCN + N OUT,%,SIEN + S SIEN=$$SCHEMA("BMXADO DATA ENTRY IDENTIFIERS") + D SS^BMXADO(.OUT,SIEN,"","VCN~1.242A~1.242A~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +MT ; MEASUREMNT TYPES + N OUT,%,SIEN + S SIEN=$$SCHEMA("BMXADO MEASUREMENT TYPES") + D SS^BMXADO(.OUT,SIEN,"","B~~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +PROB ; PATIENT PROBLEMS + N OUT,%,SIEN + S SIEN=$$SCHEMA("BMXADO PROBLEMS") + D SS^BMXADO(.OUT,SIEN,"","AA~53~53") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +PB1 ; ALT PROB RETRIEVAL TEST + N OUT,%,SIEN + S SIEN=$$SCHEMA("BMXADO PROBLEMS") + D SS^BMXADO(.OUT,SIEN,"","~221~221~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +POV ; RETURN THE POV SCHEMA + N OUT,%,SIEN + S SIEN=$$SCHEMA("BMXADO ADD POV") + D SS^BMXADO(.OUT,SIEN,"","") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +NOTES ; RETURN NOTES FOR A SPECIFIC PATIENT PROBLEMS + N OUT,%,SIEN + S SIEN=$$SCHEMA("BMXADO NOTES") + D SS^BMXADO(.OUT,SIEN,"","~~~~~NOTES~BMXADOFD~53") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +RENT ; ITERATE IN CHUNKS + ; RE-ITERATE USING THE "B" INDEX + ; START WITH PT IEN 5 AS THE "SEED", STOP AFTER PATIENT NAME = "D", MAX # RECORDS RETURNED = 5 + N OUT,%,SIEN,SEED,LSEED,X,Y + S SEED=0,LSEED="" + S SIEN=$$SCHEMA("IHS PATIENT") +RIT F D I '$G(SEED) Q + . ; D SS^BMXADO(.OUT,SIEN,SEED,"B~CA~CB~5") + . D SS^BMXADO(.OUT,SIEN,SEED,"~~~5") + . D DISP(OUT) R %:$G(DTIME,60) E S SEED="" Q + . I %?1"^" S SEED="" Q + . S X=$P(@OUT@(1),U,1) + . S SEED=$P(X,"|",3) + . I SEED=LSEED S SEED="" Q + . S LSEED=SEED + . K ^TMP("BMX ADO",$J) + . Q + Q + ; +SUB ; SUBFILE ITERATION + ; THE SCHEMA IS ATTACHED TO THE MEDICARE ELIGIBILITY FILE/ELIG DATE SUBFILE + ; THE DA STRING HAS A VALUE OF '1,',: THE IEN IN THE PARENT FILE. + ; NOTE THE COMMA IN THE DA STRING. THIS INDICATES THAT THE FILE IEN IS 1 BUT THE SUBFILE IEN IS UNSPECIFIED + N OUT,%,SIEN + S SIEN=$$SCHEMA("UPDATE MEDICARE DATES") + D SS^BMXADO(.OUT,SIEN,"1,","~~~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +DINUM ; DINUMED POINTER ITERATION + ; THE SCHEMA IS ATTACHED TO THE IHS PATIENT FILE (9000001) + ; THE IHS PATIENT FILE IS DINUM'D AND ITS .01 FIELD POINTS TO THE VA PATIENT FILE (2) + ; BECAUSE OF THE SPECIAL RELATIONSHIP BETWEEN THE FILES, WE CAN USE THE B INDEX OF FILE 2 TO ITERATE FILE 9000001. + N OUT,%,SIEN + S SIEN=$$SCHEMA("IHS PATIENT") + D SS^BMXADO(.OUT,SIEN,"","B~A~B~5") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +IXP ; INDEXED POINTER ITERATION + ; THE SCHEMA IS ATTACHED TO THE V POV FILE + ; THE AC CROSS REFERENCE INDEXES THE PATIENT FIELD + ; BY STARTING AND STOPING WITH PATIENT 1 (MAX=5) WE COLLECT THE FIRST 5 POVS FOR PATIENT 1 IN THE FILE + N OUT,%,SIEN + S SIEN=$$SCHEMA("VIEW POVS") + D SS^BMXADO(.OUT,SIEN,"","AC~1~1~5") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +AA ; ITERATE USING AA INDEX + ; INDEX IS 'AA" THE START AND STOP DATES ARE SPECIFIED IN EXTERNAL FORMAT. MAX=10 + ; THE FOLLOWING FILTERS ARE SPECIFIED IN THE LAST PARAMETER ("1|WT|C"): + ; 1=PATIENT DFN #1 + ; WT=RETURN ONLY WEIGHTS. MEASUREMENT TYPE MUST BE SPECIFIED WITH A VALID, UNAMBIGUOUS LOOKUP VALUE. + ; C=RETRUN VALUES IN CHRONOLOGICAL ORDER USE 'R' INSTEAD OF 'C' FOR REVERSE CHRONOLOGICAL ORDER. DEFAULT=C + ; THE SEED PARAMTER IS SET AND CAN BE USED TO RETURN DATA IN CHUNKS + N OUT,%,SIEN + S SIEN=$$SCHEMA("VIEW MEASUREMENTS") + D SS^BMXADO(.OUT,SIEN,"","AA~3/21/1985~6/4/1986~5~~~~1|WT|C") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +AA2 ; ITERATE USING AA INDEX + ; THIS SCHEMA IS ATTACHED TO THE VISIT FILE (9000010) + ; IN THIS CASE THERE IS NO ATTRIBUTE TYPE SO THE FILTER PARAM HAS ONLY 2 PIECES "1|R" + ; 1=PATIENT DFN + ; R=RETURN DATA IN REVERSE CHRONOLOGICAL ORDER + N OUT,%,SIEN + S SIEN=$$SCHEMA("VISITS") + D SS^BMXADO(.OUT,SIEN,"","AA~3/21/1985~6/4/1986~5~~~~1|R") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +CIT ; CUSTOM ITERATOR + ; IF COMPLEX OR UNUSUAL SORTING/FILTERING IS REQUITED, USE A CUSTOM ITERATOR + ; THE CUSTOM ITERATOR IS DEFINED BY 6TH, 7TH AND 8TH PIECES IN THE VSTG + ; PIECE 8=TAG, PIECE 9=ROUTINE, PIECE 8=A PARAMETER PASSED TO THE ENTRY POINT + ; THE 9TH PIECE CONTAINS PT DFN, TIMESTAMP, VISIT TYPE, LOC IEN, AND SERVICE CATEGORY IN A "|" DELIMTED STRING + ; THE ITERATOR CALL TAG^ROUTINE(PARAM) TO GENERATE IENS + ; IN THIS CASE THE SCHEMA IS ATTACHED TO THE VISIT FILE. + ; GIVEN THE INFORMATION IN THE PARAMETER, THE CUSTOM ITERATOR RETURNS POSSIBLE DUPLICATE VISITS + N OUT,%,SIEN + S SIEN=$$SCHEMA("VISITS") + D SS^BMXADO(.OUT,SIEN,"","~~~~~DUPV~BMXADOV2~1|4/19/04@1PM|I|4585|A~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +TRIGGER ; TEXT TRIGGER FUNCTION + N OUT,%,SIEN + S SIEN=$$SCHEMA("PATIENT DEMOGRAPHICS") + D SS^BMXADO(.OUT,SIEN,"","~1~5") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ID ; IDENTIFIER FIELD + ; THE SCHEMA IS ATTACHED TO THE VA PATIENT FILE (2) + ; THE SCHEMA HAS A BUILT IN FIELD (.01ID) THAT RETURNS THE IDENTIFIERS + ; THE ENTRY POINT THAT GENERATES THE IDETIFIERS IS STORED IN THE BMX ADO SCHEMA FILE + N OUT,%,SIEN + S SIEN=$$SCHEMA("UPDATE PATIENT DEMOGRAPHICS") + D SS^BMXADO(.OUT,SIEN,"","~1~1~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +JMD ; JOIN MASTER TO DETAIL + N OUT,%,SIEN1,SIEN2,VSTG,SIEN3,JSTG + S SIEN1=$$SCHEMA("PATIENT DEMOGRAPHICS") + S SIEN2=$$SCHEMA("VIEW MEASUREMENTS") + S SIEN3=$$SCHEMA("VIEW MEDS") + S VSTG="~1~5" ; INSTRUCTIONS FOR GATHERING DATA SET FOR PTS 1-5 FROM THE MASTER FILE + S JSTG=SIEN3_",.001,.02IEN,AA~1/1/1960~6/30/2004~~~~~|C" ; + INSTRUCTIONS FOR 1ST JOIN TO GET MEDS + S JSTG=JSTG_"@JOIN@"_SIEN2_",.001,.02IEN,AA~1/1/1988~12/31/1988~~~~~|WT|R" ; + INSTRUCTIONS FOR 2ND JOIN TO GET MSRMNTS + D SS^BMXADO(.OUT,SIEN1,"",VSTG,JSTG) + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +JVPT ; JOIN PT DEMOG TO VISIT + N OUT,%,SIEN1,SIEN2,VSTG,JSTG + S SIEN1=$$SCHEMA("PATIENT DEMOGRAPHICS") + S SIEN2=$$SCHEMA("VISITS") + S VSTG="~1~1" ; INSTRUCTIONS FOR GATHERING DATA SET FOR PT 5 FROM THE MASTER FILE + S JSTG=SIEN2_",.05IEN,.001,AC" ; + INSTRUCTIONS FOR 1ST JOIN TO GET VISIT INFO + D SS^BMXADO(.OUT,SIEN1,"",VSTG,JSTG) + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +JAC ; TEST AC INDEX + N OUT,%,SIEN1,SIEN2 + S SIEN1=$$SCHEMA("PATIENT DEMOGRAPHICS") + S SIEN2=$$SCHEMA("VIEW LABS") + S SIEN3=$$SCHEMA("VIEW MEASUREMENTS") + D SS^BMXADO(.OUT,SIEN1,"","~3~5~~~~~~"_SIEN2_",.001,.02IEN,AC@JOIN@"_SIEN3_",.001,.02IEN,AC") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +JPB ; TEST AA INDEX JOINS FOR PROBLEM LIST + N OUT,%,SIEN1,SIEN2 + S SIEN1=$$SCHEMA("PATIENT DEMOGRAPHICS") + S SIEN2=$$SCHEMA("VIEW PROBLEMS") + D SS^BMXADO(.OUT,SIEN1,"","~1~5~~~~~~"_SIEN2_",.001,.02IEN,AA") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +JSUB ; SUBFILE JOIN + ; IN THIS CASE THE RECORDS IN A PARENT FILE ARE "JOINED" TO THE RECORDS IN ONE OF ITS SUB FILES + ; THE SCHEMA IS ATTACHED TO THE "MEDICARE ELIGIBLE" FILE + ; IT IS JOINED TO ITS SUBFILE, "ELIG DATES", VIA THE UPDATE MEDICARE DATES SCHEMA + N OUT,%,SIEN1,SIEN2 + S SIEN1=$$SCHEMA("UPDATE MEDICARE INFO") + S SIEN2=$$SCHEMA("UPDATE MEDICARE DATES") + D SS^BMXADO(.OUT,SIEN1,"","~1~5~~~~~~"_SIEN2_",SUB") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADD ; ADD A NEW ENTRY + ; THIS IS A 2 STEP PROCESS: + ; FIRST GET THE SCHEMA FOR THE FILE YOU WISH TO UPDATE + ; THIS SCHEMA TYPICALLY BEGINS WITH THE WORD "UPDATE" + ; IT CONTAINS NO ID IR IEN FIELDS + ; SECOND ADD THE DATA NODE TO THE ARRAY + ; IT HAS THE SAME FORMAT AS A DATA STRING ASSOCIATED WITH THE SCHEMA EXCEPT THE FIRST "^" PIECE IS NULL + ; THIS PIECE CORRESPONDS TO THE IEN OF THE RECORD. SINCE THE RECORD HASNOT BEEN ADDED YET, IT IS NULL. + ; IN THE DATA STRING, ALL POINTER VALUES ARE PRECEDED BY THE '`' CHARACTER AND EA. STRING ENDS IN $C(30) + ; MULTIPLE DATA STRINGS CAN BE APPENDED AS NEW NODES AT THE BOTTOM OF THE ARRAY + ; IN THIS CASE WE ARE ADDING A RECORD TO THE V MEASUREMENT FILE + ; DATA STRING="^MEASUREMENT TYPE IEN^PATIENT DFN^VISIT IEN^RESULT"_$C(30) + ; THERE ARE 2 INPUT PARAMS: + ; THE CLOSED REF WHERE THE INPUT ARRAY IS STORED + ; SINCE IT IS PASSED BY REFERENCE "OUT" CAN BE NULL OR UNDEFIEND. + ; OUT WILL BE DEFINED AT THE CONCLUSION OF THE TRANSACTION. + ; THE OUTPUT IS IN THE OUT ARRAY + ; OUT(1)="OK|ien" WHERE ien IS THE IEN OF THE RECORD THAT HAS BEE ADDED. + ; IF THE TRANSACTION FAILED, AN ERROR MSG WILL BE IN THE OUT ARRAY + ; + N OUT,%,SIEN,NODE + S SIEN=$$SCHEMA("UPDATE MEASUREMENTS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`2^`1^`71164^175.75"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) ; DISPLAY THE INPUT ARRAY BEFORE UPDATING THE RECORD + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) ; EP FOR UPDAING THE RECORD + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) ; SEND BACK AN ACKNOWLEDGEMENT OR ERROR MSG + Q + ; +DELREC ; DELETE AN ENTRY + ; THE SIMPLEST WAY TO DELETE AN ENTRY IS TO PUT THE RECORD IEN IN THE DA STRING PRECEDED BY A MINUS SIGN + ; YOU CAN ALSO SET THE VALUE OF THE .01 FIELD TO "@" + ; IF THE VALUE OF THE .01 FIELD IS NULL AND THE DA STRING IS NOT PRECEDED BY A MINUS SIGN, THE TRANSACTION WILL BE CANCELLED + ; IF THE DA STRING IS NULL, THE TRANSACTION WILL BE CANCELLED + N OUT,%,SIEN,NODE,DEL + S DEL=51385 + S SIEN=$$SCHEMA("UPDATE MEASUREMENTS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="-"_DEL_$C(30) + D DISP(OUT) R %:$G(DTIME,60) ; DISPLAY THE INPUT ARRAY BEFORE UPDATING THE RECORD + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) ; EP FOR UPDAING THE RECORD + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) ; SEND BACK AN ACKNOWLEDGEMENT OR ERROR MSG + Q + ; +EDIT ; EDIT AN EXISTING ENTRY + ; SIMILAR TO ABOVE EXCEPT THAT THE FIRST "^" PIECE OF THE DATA NODE IS THE IEN OF THE RECORD TO BE EDITIED + ; NOTE THAT THERE IS NO '`' IN FRONT OF THE FIRST PIECE. IT IS A PURE INTEGER + N OUT,%,SIEN,NODE + S SIEN=$$SCHEMA("UPDATE MEASUREMENTS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="51385^^^^176^`6"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) ; DISPLAY THE INPUT ARRAY BEFORE UPDATING THE RECORD + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) ; EP FOR UPDAING THE RECORD + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) ; SEND BACK AN ACKNOWLEDGEMENT OR ERROR MSG + Q + ; +DELVAL ; DELETE A VALUE IN A FIELD + ; SIMILAR TO EDIT EXCEPT THE VALUE IS "@" + N OUT,%,SIEN,NODE + S SIEN=$$SCHEMA("UPDATE MEASUREMENTS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="51385^^^^^@"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) ; DISPLAY THE INPUT ARRAY BEFORE UPDATING THE RECORD + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) ; EP FOR UPDAING THE RECORD + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) ; SEND BACK AN ACKNOWLEDGEMENT OR ERROR MSG + Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOX2.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOX2.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOX2.m (revision 1147) @@ -0,0 +1,123 @@ +BMXADOX2 ; IHS/CIHA/GIS - RPC CALL: GENERATE AN ADO SCHEMA STRING AND DATA SET ; + ;;4.1000;BMX;;Apr 17, 2011;Build 13 + ; EXMAPLES OF FILEMAN SCHEMA GENERATION + ; +DISP(OUT) ; + D DISP^BMXADOX(OUT) + Q + ; +SCHEMA(NAME) ; GIVEN SCHEMA NAME, RETURN THE IEN + N IEN + S IEN=$O(^BMXADO("B",NAME,0)) + Q IEN + ; + ; ---------------------------------------- LISTS ------------------------------------------ + ; +FIFOLIST N OUT,%,SIEN,NODE,NEXT + S NEXT="70470;8" + S SIEN=$$SCHEMA("VEN MOJO LIST DE FIFO") + D SS^BMXADO(.OUT,SIEN,"","~~~") ; GET ENCOUNTER LIST TO BE PROCESSED BY DATA ENTRY + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +PROBLIST ; LIST PROBLEMS + S SIEN=$$SCHEMA("VEN MOJO DE DX PROBLEM") + D SS^BMXADO(.OUT,SIEN,"","AC~5~5~") ; GET PROBLEM LIST TO BE PROCESSED BY DATA ENTRY + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +PTLIST ; LIST PATIENT WITH A SPECIFIC LOOKUP VALUE + N VAL + R "PATIENT: ",VAL:DTIME E Q + I '$L(VAL) Q + I VAL?1."^" Q + S SIEN=$$SCHEMA("VEN MOJO LIST PATIENTS") + D SS^BMXADO(.OUT,SIEN,"","~~~~~PT~BMXADOV2~"_VAL) + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +CLINLIST ; LIST CLINICS + S SIEN=$$SCHEMA("VEN MOJO LIST CLINICS") + D SS^BMXADO(.OUT,SIEN,"","B~~~") ; GET PROBLEM LIST TO BE PROCESSED BY DATA ENTRY + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +SEGLIST ; LIST DE SEGMENTS + S SIEN=$$SCHEMA("VEN MOJO DE SEGMENT") + D SS^BMXADO(.OUT,SIEN,"","~~~") ; GET PROBLEM LIST TO BE PROCESSED BY DATA ENTRY + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +NOTELIST ; LIST NOTES + ;N SIEN + ;D NOTELIST^VENPCCTG(.OUT,"70470") + ;D DISP(OUT) R %:$G(DTIME,60) + ;K ^TMP("BMX ADO",$J) + Q + ; +PRVLIST ; PROVIDER LIST + N SIEN,OUT + S SIEN=$$SCHEMA("VEN MOJO LIST PROVIDERS") + D SS^BMXADO(.OUT,SIEN,"","B~~~5000") ; GET NOTE LIST TO BE PROCESSED BY DATA ENTRY + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +MLIST ; LIST MEASUREMNTS + S SIEN=$$SCHEMA("VEN MOJO LIST MEASUREMENTS") + D SS^BMXADO(.OUT,SIEN,"","B~~~") ; GET PROBLEM LIST TO BE PROCESSED BY DATA ENTRY + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +RXLIST ; A RX LIST FOR A PATIENT + N SIEN,OUT + S SIEN=$$SCHEMA("VEN MOJO RX LIST") + D SS^BMXADO(.OUT,SIEN,"","~~~~~MED~MOJORX~3") ; GET RX LIST + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +TQLIST ; TABLET QUEUE LIST + N SIEN,OUT + S SIEN=$$SCHEMA("VEN MOJO LIST TABLET QUEUE") + D SS^BMXADO(.OUT,SIEN,"","ATS~~~") ; GET PATIENT LIST + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +UHCLIST ; LIST HIDDEN COLUMNS + N SIEN,OUT + ; S SIEN=$$SCHEMA("VEN MOJO DE GFMT UHC") + D SS^BMXADO(.OUT,"VEN MOJO DE FMT GRID","","~~~") ; GET RX LIST + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +GSEGLIST ; LIST GRID PROPERTIES FOR SEGMENTS + N SIEN,OUT + D SS^BMXADO(.OUT,"VEN MOJO DE GRID FMT","","B~~~") ; GET RX LIST + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ICDLIST ; LIST ICD CODE MATCHES + ;N NARR,OUT + ;W !,"Provider narrative: " R NARR:60 E Q + ;I '$L(NARR) Q + ;D ICDMATCH^VENPCCTP(.OUT,NARR) W !! + ;D DISP(OUT) R %:$G(DTIME,60) + ;K ^TMP("BMX ADO",$J) + Q + ; +IMAGE ; LIST SEGMENT IMAGE CONTROL PARAMETERS + N SIEN,OUT + D SS^BMXADO(.OUT,"VEN MOJO DE SEG IMAGE","1,","~~~") ; GET RX LIST + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOXX.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOXX.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOXX.m (revision 1147) @@ -0,0 +1,439 @@ +BMXADOXX ; IHS/CIHA/GIS - RPC CALL: GENERATE AN ADO SCHEMA STRING AND DATA SET ; + ;;4.1000;BMX;;Apr 17, 2011;Build 13 + ; EXMAPLES OF RPMS SCHEMAE GENERATION + ; + ; +ADDPAT ; + N OUT,%,SIEN,DFN,NODE + ;S DFN=9285 + S SIEN=$$SCHEMA("UPDATE VA PATIENT") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^KANGAROO,KAP^M^1-1-83^151515555"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + ; + Q + ; +DISP(OUT) ; TEMP DISPLAY + N I,X + S I=0 W ! + F S I=$O(@OUT@(I)) Q:'I S X=@OUT@(I) S X=$TR(X,$C(30),"}") S X=$TR(X,$C(31),"{") W !,X + Q + ; +SCHEMA(NAME) ; GIVEN SCHEMA NAME, RETURN THE IEN + N IEN + S IEN=$O(^BMXADO("B",NAME,0)) + Q IEN + ; +NEXTNUM(DFN,LOC) ; RETURN THE NEXT PROBLEM NUMBER FOR A PATIENT + N X,LAST,MAX,NUM + S NUM=0,MAX="" + F S NUM=$O(^AUPNPROB("AA",DFN,LOC,NUM)) Q:NUM="" S X=$E(NUM,2,99) I +X>MAX S MAX=+X + I 'MAX Q 1 + S X=X+1 S X=X\1 + Q X + ; +DEMOG ; VIEW DEMOGRAPHICS + N OUT,%,DFN,MAX,SIEN + S DFN=1373,MAX=1000 + S SIEN=$$SCHEMA("UPDATE PATIENT DEMOGRAPHICS") + D SS^BMXADO(.OUT,SIEN,"",("~"_DFN_"~"_DFN_"~"_MAX)) + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +MEDICARE ; UPDATE MEDICARE DATES/INFO + N OUT,%,DAS,PIEN,JIEN,DFN,MAX + S DFN=1,MAX=1000 + S DAS=DFN_"," + S PIEN=$$SCHEMA("UPDATE MEDICARE DATES") + S JIEN=$$SCHEMA("UPDATE MEDICARE INFO") + D SS^BMXADO(.OUT,PIEN,DAS,("~"_DFN_"~"_DFN_"~"_MAX_"~~"_"MEDICARE~BMXADOV2~~"_JIEN_",PARENT")) + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +MEDICAID ; VIEW MEDICAID DATES/INFO + N OUT,%,DAS,PIEN,JIEN,DFN,DA + S DFN=322 + S DA(1)=$$MCDIEN^BMXADOV2(DFN) I 'DA(1) Q + S DAS=DA(1)_"," + S PIEN=$$SCHEMA("UPDATE MEDICAID DATES") + S JIEN=$$SCHEMA("UPDATE MEDICAID INFO") + D SS^BMXADO(.OUT,PIEN,DAS,("~~~~~MEDICAID~BMXADOV2~~"_JIEN_",PARENT")) + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +PVTINS ; VIEW PRIVATE INSURANCE DATES/INFO + N OUT,%,DAS,SIEN,DFN + S DFN=96 + S DAS=DFN_"," + S SIEN=$$SCHEMA("UPDATE PVT INSURANCE INFO") + D SS^BMXADO(.OUT,SIEN,DAS,"~~~~~PVTINS~BMXADOV2~~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +VISIT ; VIEW VISITS + N OUT,%,SIEN,DFN + S DFN=9285 + S SIEN=$$SCHEMA("VISITS") + D SS^BMXADO(.OUT,SIEN,"","AA~3/21/1968~6/4/2004~100~~~~9285|C") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +DUPVIS ; DISPLAY POSSIBLE DUPLICATE VISITS + N OUT,%,SIEN,DFN + S DFN=9285 + S SIEN=$$SCHEMA("VISITS") + D SS^BMXADO(.OUT,SIEN,"","~~~~~DUPV~BMXADOV2~9285|5/24/04@1PM|I|516|~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDVIS ; ADD A NEW VISIT + N OUT,%,SIEN,DFN,NODE + S DFN=9285 + S SIEN=$$SCHEMA("VISITS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^JUN 03, 2004@01:32^I^`9285^`516^A^`2"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +POV ; DISPLAY POVS + N OUT,%,SIEN,DFN + S DFN=9285 + S SIEN=$$SCHEMA("VIEW POVS") + D SS^BMXADO(.OUT,SIEN,"","AA~3/21/1965~6/4/2004~100~~~~9285|C") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDPOV ; ADD A POV TO AN EXISITING VISIT + N OUT,%,SIEN,DFN,NODE + S DFN=9285 + S SIEN=$$SCHEMA("UPDATE POVS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`8718^`9285^`8337^DM II ON EXPMTL MEDS^2^P"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +EDITPOV ; ADD A POV TO AN EXISITING VISIT + N OUT,%,SIEN,DFN,NODE + S DFN=1 + S SIEN=$$SCHEMA("UPDATE POVS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="2815^`8718^`9285^`8337^DM II ON SPECIAL MEDS^2^P"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +PROB ; DISPLAY PROBLEMS + N OUT,%,SIEN,DFN + S DFN=1373 + S SIEN=$$SCHEMA("VIEW PROBLEMS") + D SS^BMXADO(.OUT,SIEN,"","AA~"_DFN_"~"_DFN_"~~~~~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDPROB ; ADD A PROBLEM TO THE PROBLEM LIST + N OUT,%,SIEN,DFN,NODE,NUM,LOC,ICD,TEXT,AIR,IEN + S ICD=2477 + S TEXT="HYPERTENSION ON SPECIAL MEDS" + S DFN=1373,LOC=DUZ(2) + S SIEN=$$SCHEMA("UPDATE PROBLEMS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)=U_"`"_ICD_U_"`"_DFN_U_DT_U_U_TEXT_U_"`"_LOC_U_DT_U_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + S IEN=+$P(OUT(1),"|",2) I '$D(^AUPNPROB(IEN,0)) Q + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + K OUT + S NUM=$$NEXTNUM(DFN,LOC) I 'NUM Q + S SIEN=$$SCHEMA("UPDATE PROBLEM NUMBER") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)=IEN_U_NUM_U_"A"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +MEAS ; DISPLAY MEASUREMENTS + N OUT,%,SIEN,DFN + S DFN=2 + S SIEN=$$SCHEMA("VIEW MEASUREMENTS") + D SS^BMXADO(.OUT,SIEN,"","AA~3/21/1965~6/4/2004~10~~~~"_DFN_"|WT|C") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDMEAS ; UPDATE V MEASUREMENT FILE + N OUT,%,SIEN,DFN,NODE + S DFN=2 + S SIEN=$$SCHEMA("UPDATE MEASUREMENTS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`2^`"_DFN_"^`7806^172.75"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +MEDS ; DISPLAY MEDS + N OUT,%,SIEN,DFN + S DFN=152 + S SIEN=$$SCHEMA("VIEW MEDS") + D SS^BMXADO(.OUT,SIEN,"","AA~1/1/1969~12/31/2004~10~~~~"_DFN_"|C") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDMEDS ; UPDATE V MED FILE + N OUT,%,SIEN,DFN,NODE + S DFN=2 + S SIEN=$$SCHEMA("UPDATE MEDS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`305^`"_DFN_"^`7806^T1T QID^40"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +LAB ; DISPLAY LAB TEST RESULTS + N OUT,%,SIEN,DFN + S DFN=280 + S SIEN=$$SCHEMA("VIEW LABS") + D SS^BMXADO(.OUT,SIEN,"","AA~1/1/1965~12/31/2003~10~~~~"_DFN_"|175|C") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDLAB ; UPDATE V LAB + N OUT,%,SIEN,DFN,NODE + S DFN=2 + S SIEN=$$SCHEMA("UPDATE LABS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`175^`"_DFN_"^`7806^216"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +EXAMS ; DISPLAY EXAMS + N OUT,%,SIEN,DFN + S DFN=1373 + S SIEN=$$SCHEMA("VIEW EXAMS") + D SS^BMXADO(.OUT,SIEN,"","AA~1/1/1966~12/31/2003~10~~~~"_DFN_"|6|C") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDEXAMS ; UPDATE V EXAM + S DFN=2 + S SIEN=$$SCHEMA("UPDATE EXAMS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`6^`"_DFN_"^`7806^NORMAL"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +IMM ; DISPLAY IMMUNIZATIONS + N OUT,%,SIEN,DFN + S DFN=54 + S SIEN=$$SCHEMA("VIEW IMM") + D SS^BMXADO(.OUT,SIEN,"","AA~1/1/1966~12/31/2003~10~~~~"_DFN_"|101|C") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +PROV ; DISPLAY PROVIDERS FOR A VISIT + N OUT,%,SIEN,VIEN + S VIEN=4703 + S SIEN=$$SCHEMA("VIEW PROV") + D SS^BMXADO(.OUT,SIEN,"","AD~"_VIEN_"~"_VIEN_"~10~~~~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDPROV ; UPDATE V PROVIDER FILE + N OUT,%,SIEN,NODE,PIEN,DFN + S PIEN=DUZ,DFN=2 + I $P(^DD(9000010.06,.01,0),U,3)["DIC(6" S PIEN=$P(^VA(200,PIEN,0),U,16) ; CONVERT FILE 200 TO FILE 16 IF NECESS. + S SIEN=$$SCHEMA("UPDATE PROV") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`"_PIEN_"^`"_DFN_"^`7806^P"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +PROC ; DISPLAY PROCEDURES + N OUT,%,SIEN,DFN + S DFN=235 + S SIEN=$$SCHEMA("VIEW PROCEDURES") + D SS^BMXADO(.OUT,SIEN,"","AA~1/1/1965~12/31/2003~10~~~~"_DFN_"|C") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDPROC ; UPDATE V PROCEDURES FILE + N OUT,%,SIEN,DFN,NODE + S DFN=2 + S SIEN=$$SCHEMA("UPDATE PROCEDURES") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`2198^`"_DFN_"^`7806^`8718"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +CPT ; DISPLAY CPT CODES + N OUT,%,SIEN,DFN + S VIEN=8082 + S SIEN=$$SCHEMA("VIEW CPT") + D SS^BMXADO(.OUT,SIEN,"","AD~"_VIEN_"~"_VIEN_"~10~~~~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDCPT ; UPDATE V CPT FILE + N OUT,%,SIEN,DFN,NODE + S DFN=2 + S SIEN=$$SCHEMA("UPDATE CPT") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`10000^`"_DFN_"^`7806"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +PH ; DISPLAY PERSONAL HISTORY + N OUT,%,SIEN,DFN + S DFN=1373 + S SIEN=$$SCHEMA("VIEW PERSONAL HISTORY") + D SS^BMXADO(.OUT,SIEN,"","AC~"_DFN_"~"_DFN_"~~~~~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDPH ; UPDATE PERSONAL HX + N OUT,%,SIEN,DFN,NODE,ICD,TEXT + S ICD=2477 + S TEXT="PERSONAL HISTORY OF SERIOUS PROBLEMS" + S DFN=2 + S SIEN=$$SCHEMA("UPDATE PERSONAL HISTORY") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`11353^`"_DFN_"^2851219^"_TEXT_"^2810303"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +FH ; DISPLAY FAMILY HX + N OUT,%,SIEN,DFN + S DFN=631 + S SIEN=$$SCHEMA("VIEW FAMILY HISTORY") + D SS^BMXADO(.OUT,SIEN,"","AC~"_DFN_"~"_DFN_"~~~~~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDFH ; UPDATE FAMILY HISTORY + N OUT,%,SIEN,DFN,NODE,ICD,TEXT + S ICD=2477 + S TEXT="FAMILY HISTORY OF SERIOUS PROBLEMS" + S DFN=2 + S SIEN=$$SCHEMA("UPDATE FAMILY HISTORY") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`7571^`"_DFN_"^2851219^"_TEXT_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +HF ; DISPLAY HEALTH FACTORS + N OUT,%,SIEN,DFN + S DFN=2390 + S SIEN=$$SCHEMA("VIEW HEALTH FACTORS") + D SS^BMXADO(.OUT,SIEN,"","AC"_"~"_DFN_"~"_DFN_"~~~~~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDHF ; UPDATE HEALTH FACTORS FILE + N OUT,%,SIEN,DFN,NODE + S DFN=2 + S SIEN=$$SCHEMA("UPDATE HEALTH FACTORS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`3^`"_DFN_U_DT_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; +REPRO ; DISPLAY REPRODUCTIVE FACTORS + N OUT,%,SIEN,DFN + S DFN=1373 + S SIEN=$$SCHEMA("VIEW REPRODUCTIVE FACTORS") + D SS^BMXADO(.OUT,SIEN,"","B"_"~"_DFN_"~"_DFN_"~~~~~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADDREPRO ; UPDATE REPRODUCTIVE FACTORS + ; THE .O1 FIELD IS DINUMED + ; THEREFORE, THE FILER WILL AUTOMATICALLY SWITCH TO MOD MODE IF A RECORD ALREADY EXISTS FOR THIS PATIENT + N OUT,%,SIEN,DFN,NODE + S DFN=2 + ; I $D(^AUPNREP(DFN)) G ERF + S SIEN=$$SCHEMA("UPDATE REPRODUCTIVE FACTORS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`"_DFN_"^G5P4LC3SA1TA0^"_DT_"^2^3040101^"_DT_$C(30) + D DISP(OUT) R %:$G(DTIME,60) + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) + Q + ; Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOXY.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOXY.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXADOXY.m (revision 1147) @@ -0,0 +1,296 @@ +BMXADOXY ; IHS/CIHA/GIS - RPC CALL: GENERATE AN ADO SCHEMA STRING AND DATA SET ; + ;;4.1000;BMX;;Apr 17, 2011;Build 13 + ; EXMAPLES OF FILEMAN SCHEMA GENERATION + ; + ; + ; +DISP(OUT) ; TEMP DISPLAY OF THE ANR + N I,X + S I=0 W ! + F S I=$O(@OUT@(I)) Q:'I S X=@OUT@(I) S X=$TR(X,$C(30),"}") S X=$TR(X,$C(31),"{") W !,X + Q + ; +SCHEMA(NAME) ; GIVEN SCHEMA NAME, RETURN THE IEN + N IEN + S IEN=$O(^BMXADO("B",NAME,0)) + Q IEN + ; +NUM ; ITERATE BY IEN + ; IX="",START WITH IEN=1, STOP AFTER IEN=20, MAX # RECORDS RETURNED = 5 + ; TO VIEW INTERNAL VALUES SET VSTG="~1~20~5~I" + N OUT,%,SIEN + S SIEN=$$SCHEMA("IHS PATIENT") + D SS^BMXADO(.OUT,SIEN,"","~1~20~5") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +IX ; ITERATE BY INDEX + ; ITERATE USING THE "B" INDEX + ; START WITH PT NAME "C", STOP AFTER PATIENT NAME = "D", MAX # RECORDS RETURNED = 5 + N OUT,%,SIEN + S SIEN=$$SCHEMA("IHS PATIENT") + D SS^BMXADO(.OUT,SIEN,"","B~C~D~5") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +RENT ; ITERATE IN CHUNKS + ; RE-ITERATE USING THE "B" INDEX + ; START WITH PT IEN 5 AS THE "SEED", STOP AFTER PATIENT NAME = "D", MAX # RECORDS RETURNED = 5 + N OUT,%,SIEN,SEED,LSEED,X,Y + S SEED=0,LSEED="" + S SIEN=$$SCHEMA("IHS PATIENT") +RIT F D I '$G(SEED) Q + . D SS^BMXADO(.OUT,SIEN,SEED,"B~CA~CB~5") + . D DISP(OUT) R %:$G(DTIME,60) E S SEED="" Q + . I %?1"^" S SEED="" Q + . S X=$P(@OUT@(1),U,1) + . S SEED=$P(X,"|",3) + . I SEED=LSEED S SEED="" Q + . S LSEED=SEED + . K ^TMP("BMX ADO",$J) + . Q + Q + ; +SUB ; SUBFILE ITERATION + ; THE SCHEMA IS ATTACHED TO THE MEDICARE ELIGIBILITY FILE/ELIG DATE SUBFILE + ; THE DA STRING HAS A VALUE OF '4,',: THE IEN IN THE PARENT FILE (PATIENT DFN). + ; NOTE THE COMMA IN THE DA STRING. THIS INDICATES THAT THE FILE IEN IS 4 BUT THE SUBFILE IEN IS UNSPECIFIED + N OUT,%,SIEN + S SIEN=$$SCHEMA("UPDATE MEDICARE DATES") + ;D SS^BMXADO(.OUT,SIEN,"1,","~~~") + D SS^BMXADO(.OUT,18,"1,","~~~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +DINUM ; DINUMED POINTER ITERATION + ; THE SCHEMA IS ATTACHED TO THE PATIENT FILE (9000001) + ; THE PATIENT FILE IS DINUM'D AND ITS .01 FIELD POINTS TO THE VA PATIENT FILE (2) + ; BECAUSE OF THE SPECIAL RELATIONSHIP BETWEEN THE FILES, WE CAN USE THE B INDEX OF FILE 2 TO ITERATE FILE 9000001. + N OUT,%,SIEN + S SIEN=$$SCHEMA("IHS PATIENT") + D SS^BMXADO(.OUT,SIEN,"","B~A~B~5") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +IXP ; INDEXED POINTER ITERATION + ; THE SCHEMA IS ATTACHED TO THE V POV FILE + ; THE AC CROSS REFERENCE INDEXES THE PATIENT FIELD + ; BY STARTING AND STOPING WITH PATIENT 235 (MAX=5) WE COLLECT THE FIRST 5 POVS FOR PATIENT 235 IN THE FILE + N OUT,%,SIEN + S SIEN=$$SCHEMA("VIEW POVS") + D SS^BMXADO(.OUT,SIEN,"","AC~235~235~5") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +AA ; ITERATE USING AA INDEX + ; INDEX IS 'AA" THE START AND STOP DATES ARE SPECIFIED IN EXTERNAL FORMAT. MAX=10 + ; THE FOLLOWING FILTERS ARE SPECIFIED IN THE LAST PARAMETER ("235|WT|C"): + ; 235=PATIENT DFN #235 + ; WT=RETURN ONLY WEIGHTS. MEASUREMENT TYPE MUST BE SPECIFIED WITH A VALID, UNAMBIGUOUS LOOKUP VALUE. + ; C=RETRUN VALUES IN CHRONOLOGICAL ORDER USE 'R' INSTEAD OF 'C' FOR REVERSE CHRONOLOGICAL ORDER. DEFAULT=C + ; THE SEED PARAMTER IS SET AND CAN BE USED TO RETURN DATA IN CHUNKS + N OUT,%,SIEN + S SIEN=$$SCHEMA("VIEW MEASUREMENTS") + D SS^BMXADO(.OUT,SIEN,"","AA~3/21/1965~6/4/2004~5~~~~235|WT|C") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +AA2 ; ITERATE USING AA INDEX + ; THIS SCHEMA IS ATTACHED TO THE VISIT FILE (9000010) + ; IN THIS CASE THERE IS NO ATTRIBUTE TYPE SO THE FILTER PARAM HAS ONLY 2 PIECES "1|R" + ; 235=PATIENT DFN + ; R=RETURN DATA IN REVERSE CHRONOLOGICAL ORDER + N OUT,%,SIEN + S SIEN=$$SCHEMA("VISITS") ;12 + D SS^BMXADO(.OUT,SIEN,"","AA~3/21/1965~6/4/2004~5~~~~235|R") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +CIT ; CUSTOM ITERATOR + ; IF COMPLEX OR UNUSUAL SORTING/FILTERING IS REQUITED, USE A CUSTOM ITERATOR + ; THE CUSTOM ITERATOR IS DEFINED BY 6TH, 7TH AND 8TH PIECES IN THE VSTG + ; PIECE 8=TAG, PIECE 9=ROUTINE, PIECE 8=A PARAMETER PASSED TO THE ENTRY POINT + ; THE 9TH PIECE CONTAINS PT DFN, TIMESTAMP, VISIT TYPE, LOC IEN, AND SERVICE CATEGORY IN A "|" DELIMTED STRING + ; THE ITERATOR CALL TAG^ROUTINE(PARAM) TO GENERATE IENS + ; IN THIS CASE THE SCHEMA IS ATTACHED TO THE VISIT FILE. + ; GIVEN THE INFORMATION IN THE PARAMETER, THE CUSTOM ITERATOR RETURNS POSSIBLE DUPLICATE VISITS + N OUT,%,SIEN + S SIEN=$$SCHEMA("VISITS") + D SS^BMXADO(.OUT,SIEN,"","~~~~~DUPV~BMXADOV2~9285|5/24/04@1PM|I|516|~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ID ; IDENTIFIER FIELD + ; THE SCHEMA IS ATTACHED TO THE VA PATIENT FILE (2) + ; THE SCHEMA HAS A BUILT IN FIELD (.01ID) THAT RETURNS THE IDENTIFIERS + ; THE ENTRY POINT THAT GENERATES THE IDETIFIERS IS STORED IN THE BMX ADO SCHEMA FILE + ; PATIENT DFN=235 + N OUT,%,SIEN + S SIEN=$$SCHEMA("UPDATE PATIENT DEMOGRAPHICS") + D SS^BMXADO(.OUT,SIEN,"","~235~235~") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +JSTD ; STANDARD JOIN + ; BY SPECIFYING A JOIN IN THE VSTG, MULTIPLE SCHEMAE AND DATA SETS ARE RETURNED IN ONE PASS + ; THE SCHEMA IS ATTACHED TO THE V MEASUREMENT FILE + ; THIS IS JOINED TO A SECOND FILE, THE VA PATIENT FILE VIA A JOIN + ; THE JOIN IS BASTED ON THE FACT THAT THE PATIENT FIELD (.02) IN THE V MEASUREMENT FILE POINTS TO THE VA PATIENT FILE + ; THE JOIN PARAMETER IS THE 9TH PIECE OF THE VSTG. IT CONSISTS OF 2 PIECES DELIMITED BY A "," + ; PIECE 1 IS THE SCHEMA THAT YOU ARE JOINING TO + ; PIECE 2 IS THE FIELD IN THE PRIMARY FILE THAT ENABLES THE JOIN + ; THE DATA SET FROM THE SECOND (JOIN) FILE CONTAINS ONLY THOSE RECORDS NECESSARY TO COMPLETE THE JOIN + ; PATIENT DFN=235, INDEX=AA, MAX=5, START=3/21/65, STOP=6/4/04 + N OUT,%,SIEN1,SIEN2 + S SIEN2=$$SCHEMA("VIEW MEASUREMENTS") + S SIEN1=$$SCHEMA("PATIENT DEMOGRAPHICS") + ;SIEN1=23, SIEN2=11 + ;D SS^BMXADO(.OUT,SIEN1,"","AA~3/21/1965~6/4/2004~5~~~~234|WT|C~"_SIEN2_",.02") + D SS^BMXADO(.OUT,SIEN1,"","~234~236~~~~~~"_SIEN2_",.01") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +HWSTD ; + ; PATIENT DFN=235, INDEX=AA, MAX=5, START=3/21/65, STOP=6/4/04 + N OUT,%,SIEN1,SIEN2 + S SIEN1=$$SCHEMA("PATIENT DEMOGRAPHICS") + S SIEN2=$$SCHEMA("VIEW MEASUREMENTS") + ;SIEN2=23, SIEN1=11 + D SS^BMXADO(.OUT,SIEN1,"","~235~250~~~~~~"_SIEN2_",.01") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +JMD ;JOIN MASTER TO DETAIL + N OUT,%,SIEN1,SIEN2,SIEN3,VSTG + S SIEN1=$$SCHEMA("PATIENT DEMOGRAPHICS") + S SIEN2=$$SCHEMA("VIEW MEASUREMENTS") + S SIEN3=$$SCHEMA("VIEW MEDS") + S VSTG="~1~5~~~~~~" + ;S VSTG=VSTG_SIEN3_",.001,.02IEN,AA~1/1/1960~6/30/2004~~~~~|C" + S VSTG=VSTG_SIEN3_",.001,.02IEN,AA~1/1/1960~6/30/2004~~~~~|C" + ;S VSTG="~1~5~~~~~~23,.001,.02IEN,AA~1/1/1960~6/30/2004~~~~~|WT|C" + ;BMX ADO SS^11^^~1~5~~~~~~23,.001,.02IEN,AA~1/1/1960~6/30/2004~~~~~|WT|C + ;BMX ADO SS^11^^~1~5~~~~~~25,.001,.02IEN,AA~1/1/1960~6/30/2004~~~~~|C + D SS^BMXADO(.OUT,SIEN1,"",VSTG) + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +JSUB ; SUBFILE JOIN + ; IN THIS CASE THE RECORDS IN A PARENT FILE ARE "JOINED" TO THE RECORDS IN ONE OF ITS SUB FILES + ; THE SCHEMA IS ATTACHED TO THE "MEDICARE ELIGIBLE" FILE + ; IT IS JOINED TO ITS SUBFILE, "ELIG DATES", VIA THE UPDATE MEDICARE DATES SCHEMA + ; THE SYNTAX FOR THE JOIN PIECE IS "sien2,SUB" WHERE sien2=IEN OF SECOND SCHEMA + ; PATIENT DFN=4 + N OUT,%,SIEN1,SIEN2 + S SIEN1=$$SCHEMA("UPDATE MEDICARE INFO") ;17 + S SIEN2=$$SCHEMA("UPDATE MEDICARE DATES") ;18 + ;BMX ADO SS^17^^~4~5~~~~~~18,SUB + D SS^BMXADO(.OUT,SIEN1,"","~4~5~~~~~~"_SIEN2_",SUB") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +JPAR ; PARENT FILE JOIN + ; SIMILAR TO A SUBFILE JOIN EXCEPT THE SUB-FILE IS TREATED AS THE PRIMARY FILE AND IT IS JOINED TO ITS PARENT + ; BECAUSE WE ARE STARTING IN A SUBFILE, THE DA STRING CONTAINS THE IEN OF THE PARENT FILE ("4," + ; THE SYNTAX OF THE 9TH PIECE IS "sien2,PARENT" WHERE sien2 IS THE IEN OF THE SECONDARY SCHEMA + ; PATIENT DFN=4 + N OUT,%,SIEN1,SIEN2 + S SIEN1=$$SCHEMA("UPDATE MEDICARE DATES") + S SIEN2=$$SCHEMA("UPDATE MEDICARE INFO") + D SS^BMXADO(.OUT,SIEN1,"4,","~~~5~~~~~"_SIEN2_",PARENT") + D DISP(OUT) R %:$G(DTIME,60) + K ^TMP("BMX ADO",$J) + Q + ; +ADD ; ADD A NEW ENTRY + ; THIS IS A 2 STEP PROCESS: + ; FIRST GET THE SCHEMA FOR THE FILE YOU WISH TO UPDATE + ; THIS SCHEMA'S NAME TYPICALLY BEGINS WITH THE WORD "UPDATE" + ; IT CONTAINS NO ID OR IEN FIELDS + ; SECOND ADD THE DATA NODE TO THE ARRAY + ; IT HAS THE SAME FORMAT AS A DATA STRING ASSOCIATED WITH THE SCHEMA EXCEPT THE FIRST "^" PIECE IS NULL + ; THIS PIECE CORRESPONDS TO THE IEN OF THE RECORD. SINCE THE RECORD HAS NOT BEEN ADDED YET, IT IS NULL. + ; IN THE DATA STRING, ALL POINTER VALUES ARE PRECEDED BY THE '`' CHARACTER AND EA. STRING ENDS IN $C(30) + ; MULTIPLE DATA STRINGS CAN BE APPENDED AS NEW NODES AT THE BOTTOM OF THE ARRAY + ; IN THIS CASE WE ARE ADDING A RECORD TO THE V MEASUREMENT FILE + ; DATA STRING="^MEASUREMENT TYPE IEN^PATIENT DFN^VISIT IEN^RESULT"_$C(30) + ; THERE ARE 2 INPUT PARAMS: + ; THE CLOSED REF WHERE THE INPUT ARRAY IS STORED + ; SINCE IT IS PASSED BY REFERENCE "OUT" CAN BE NULL OR UNDEFIEND. + ; OUT WILL BE DEFINED AT THE CONCLUSION OF THE TRANSACTION. + ; THE OUTPUT IS IN THE OUT ARRAY + ; OUT(1)="OK|ien" WHERE ien IS THE IEN OF THE RECORD THAT HAS BEE ADDED. + ; IF THE TRANSACTION FAILED, AN ERROR MSG WILL BE IN THE OUT ARRAY + ; MEASUREMENT TYPE=2, PATIENT DFN=2, VISIT IEN=7806, PATIENT'S WEIGHT=172.75 + N OUT,%,SIEN,NODE,DFN + S DFN=2 + S SIEN=$$SCHEMA("UPDATE MEASUREMENTS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="^`2^`"_DFN_"^`7806^172.75"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) ; DISPLAY THE INPUT ARRAY BEFORE UPDATING THE RECORD + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) ; EP FOR UPDAING THE RECORD + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) ; SEND BACK AN ACKNOWLEDGEMENT OR ERROR MSG + Q + ; +DEL ; DELETE A RECORD + ; THE SIPLEST WAY TO DELETE AN ENTRY IS TO PUT THE RECORD IEN IN THE DA STRING PRECEDED BY A MINUS SIGN + ; YOU CAN ALSO SET THE VALUE OF THE .01 FIELD TO "@" + ; IF THE VALUE OF THE .01 FIELD IS NULL AND THE DA STRING IS NOT PRECEDED BY A MINUS SIGN, THE TRANSACTION WILL BE CANCELLED + ; IF THE DA STRING IS NULL, THE TRANSACTION WILL BE CANCELLED + ; IN THIS EXAMPLE, WE DELETE A V MEASUREMENT RECORD THAT WAS JUST ADDED + N OUT,%,SIEN,NODE,DEL + S DEL=1621 + S SIEN=$$SCHEMA("UPDATE MEASUREMENTS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="-"_DEL_$C(30) + D DISP(OUT) R %:$G(DTIME,60) ; DISPLAY THE INPUT ARRAY BEFORE UPDATING THE RECORD + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) ; EP FOR UPDAING THE RECORD + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) ; SEND BACK AN ACKNOWLEDGEMENT OR ERROR MSG + Q + ; +EDIT ; EDIT AN EXISTING ENTRY + ; SIMILAR TO ABOVE EXCEPT THAT THE FIRST "^" PIECE OF THE DATA NODE IS THE IEN OF THE RECORD TO BE EDITIED + ; NOTE THAT THERE IS NO '`' IN FRONT OF THE FIRST PIECE. IT IS A PURE INTEGER + ; LAB TEST=175, PATIENT DFN=2, VISIT IEN=8040, PT'S GLUCOSE=276, ANORMAL="ABNORMAL" + N OUT,%,SIEN,NODE + S SIEN=$$SCHEMA("UPDATE LABS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="279^`175^`2^`8040^280^H"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) ; DISPLAY THE INPUT ARRAY BEFORE UPDATING THE RECORD + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) ; EP FOR UPDAING THE RECORD + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) ; SEND BACK AN ACKNOWLEDGEMENT OR ERROR MSG + Q + ; +DELVAL ; DELETE A VALUE IN A FIELD + ; SIMILAR TO EDIT EXCEPT THE VALUE IS "@" + ; DELETE WILL BE ABORTED IF IF FILEMAN SAYS THIS IS A REQUIRED FIELD + N OUT,%,SIEN,NODE + S SIEN=$$SCHEMA("UPDATE LABS") + D SS^BMXADO(.OUT,SIEN,"","") ; GET SCHEMA + S NODE=$O(^TMP("BMX ADO",$J,999999),-1)+1 + S ^TMP("BMX ADO",$J,NODE)="279^`175^`2^`8040^^@"_$C(30) + D DISP(OUT) R %:$G(DTIME,60) ; DISPLAY THE INPUT ARRAY BEFORE UPDATING THE RECORD + D BAFM^BMXADOF1(.OUT,$NA(^TMP("BMX ADO",$J))) ; EP FOR UPDAING THE RECORD + K ^TMP("BMX ADO",$J) + W !!,OUT S %=0 F S %=$O(OUT(%)) Q:'% W !,OUT(%) ; SEND BACK AN ACKNOWLEDGEMENT OR ERROR MSG + Q + ; Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXE01.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXE01.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXE01.m (revision 1147) @@ -0,0 +1,52 @@ +BMXE01 ; IHS/OIT/FJE - ENVIRONMENT CHECK FOR BMX 2.0 ; 4/6/11 4:20pm + ;;4.1000;BMX;;Apr 17, 2011;Build 13 + ; + S $P(LINE,"*",81)="" + S XPDNOQUE="NO QUE" ;NO QUEUING ALLOWED + S XPDABORT=0 + I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." S XPX="DUZ" D SORRY Q + ; + I '$L($G(DUZ(0))) W !,"DUZ(0) UNDEFINED OR NULL." S XPX="DUZ" D SORRY Q + ; + D HOME^%ZIS,DT^DICRW + S X=$P($G(^VA(200,DUZ,0)),U) + I $G(X)="" W !,"Who are you????" S XPX="DUZ" D SORRY Q + W !,"Hello, "_$P(X,",",2)_" "_$P(X,",") + W !!,"Checking Environment for Install of Version "_$P($T(+2),";",3)_" of "_$P($T(+2),";",4)_"." + ; + S X=$G(^DD("VERSION")) + W !!,"Need at least FileMan 22.....FileMan "_X_" Present" + I X<22 S XPX="FM" D SORRY Q + ; + S X=$G(^DIC(9.4,$O(^DIC(9.4,"C","XU",0)),"VERSION")) + W !!,"Need at least Kernel 8.0.....Kernel "_X_" Present" + I +X<8 S XPX="KERNEL" D SORRY Q + ; + S X=$G(^DIC(9.4,$O(^DIC(9.4,"C","XB",0)),"VERSION")) + W !!,"Need at least XB/ZIB 3.....XB/ZIB "_X_" Present" + I +X<2 S XPX="XB" D SORRY Q + ; +ENVOK ; If this is just an environ check, end here. + W !!,"ENVIRONMENT OK." + ; + ; The following line prevents the "Disable Options..." and "Move + ; Routines..." questions from being asked during the install. + I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0 + QUIT +SORRY ; + K DIFQ + S XPDABORT=1 + W *7,!!!,"Sorry....something is wrong with your environment" + W !,"Aborting BMX Version 4.0 Install!" + W !,"Correct error and reinstall otherwise" + W !,"please print/capture this screen and notify" + W !,"technical support." + W !!,LINE + D BMES^XPDUTL("Sorry....something is wrong with your environment") + D BMES^XPDUTL("Enviroment ERROR "_$G(XPX)) + D BMES^XPDUTL("Aborting BMX 4 install!") + D BMES^XPDUTL("Correct error and reinstall otherwise") + D BMES^XPDUTL("please print/capture this screen and notify") + D BMES^XPDUTL("technical support.") + QUIT + ; Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXEHR.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXEHR.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXEHR.m (revision 1147) @@ -0,0 +1,244 @@ +BMXEHR ; IHS/OIT/GIS - ENCAPSULATE BMX CALLS FOR USE WITHIN THE EHR 14 Jan 2009 4:37 PM ; 04 Jun 2010 3:16 PM + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; + ; +CIARPCD(XOUT,IN,A,B,C) ; EP - RPC: CIABMX - EHR WRAPER FOR BMX + ; + S A=$G(A),B=$G(B),C=$G(C) + ; D DEBUG^%Serenji("CIARPCD^BMXEHR(.XOUT,IN,A,B,C)") + Q +CIARPC(XOUT,IN,A,B,C) ; EP - RPC: CIABMX - EHR WRAPER FOR BMX + ; INPUT = CF QUAD OR AN ADO RECORD SET + ; OUT = BMX DATA ARRAY IN "^TMP("BMX DATA",$J) + S XOUT=$NA(^TMP("BMX DATA",$J)),@XOUT@(1)="" + ; S BMXR=$NA(^TMP("BMX ADO",$J)) + I $G(A)'="" S IN=IN_"^"_A + I $G(IN)'["{BMX}" Q + N X,Y,Z,BMXTBUF,BMXHTYP,BMXTLEN,L,BMXDTIME,BMXPLEN,STG,BMXTIME,BMXPTYPE,BMXWRAP,BMXR,I,SECURE,CTXT,DTSG,NODE,L + S CTXT="",BMXTBUF="",RESULT="" +LONG D PARSE(IN,.CTXT,.BMXTBUF) I $L(BMXTBUF),$L(CTXT) G CALLPNOW ; INPUT STRING IS IN LONG FORMAT +SHORT D PARSE1 I '$L(BMXTBUF)!('$L(CTXT)) Q ; LONG PARSE FAILED, SO INPUT STRING MUST BE IN SHORT FORMAT +CALLPNOW D CRCONTXT^XWBSEC(.SECURE,CTXT) I 'SECURE Q ; CONFIRM THAT THE USER HAS CONTEXT SECURITY + D CALLP(.BMXR,BMXTBUF,.BMXSTR) ; RUN THE RPC + I BMXSTR="",$L($G(BMXR)) S BMXSTR=BMXR + S BMXPTYPE=$S('$D(BMXPTYPE):1,BMXPTYPE<1:1,BMXPTYPE>6:1,1:BMXPTYPE) + IF BMXPTYPE'=1,BMXPTYPE'=5,$L($G(BMXSEC))'>0 + E S @XOUT@(1)=$G(BMXSTR) Q ; -- SIMPLE STRING +ARR ; -- word processing or global array, or global instance + I $G(BMXR)="" S BMXR="BMXR" + I '$O(@BMXR@(0)) Q + S I="",NODE=1,L=0 + F S I=$O(@BMXR@(I)) Q:I="" D + . S DSTG=@BMXR@(I) + . I '$L(DSTG) Q + . S %=$L(DSTG)+L I %<32000 S @XOUT@(NODE)=@XOUT@(NODE)_DSTG,L=% Q + . S NODE=NODE+1,L=$L(DSTG) + . S @XOUT@(NODE)=DSTG + . Q +CLEANUP K @BMXR + Q + ; +PARSE(IN,CTXT,STG1) ; EP - PARSE INPUT STRING, LONG FORMAT + S CTXT="",STG1="" + I $L($G(IN)) + E Q + N A,B,C,X,Y,Z,%,L1,L2,L3,L4 + S A=$E(IN,1,5) I A'="{BMX}" Q + S L1=+$E(IN,16,18) I 'L1 Q + S B=+$E(IN,18+L1+6) I B'=1 Q + S L2=+$E(IN,6,10) I 'L2 Q + S C=$E(IN,16,L2),D=$E(IN,L2+1,9999) + S L3=+$E(D,11,15) + S CTXT=$E(D,16,L3+15) + S E=$E(D,L3+16,9999) + S STG1=C_E + Q + ; +PARSE1 ; PARSE INPUT STRING, SHORT FORMAT + S STG=IN,BMXTIME=$G(BMXTIME,60) + S BMXTBUF=$E(STG,1,11),STG=$E(STG,12,999) + S BMXHTYP=5 + S BMXTLEN=$E(BMXTBUF,6,10)-15,L=$E(BMXTBUF,11,11) + S BMXTBUF=$E(STG,1,4),STG=$E(STG,5,999) + S BMXTBUF=L_BMXTBUF + S BMXPLEN=BMXTBUF + S BMXTBUF=$E(STG,1,BMXPLEN),STG=$E(STG,(BMXPLEN+1),999) + K BMXR,BMXARY + S BMXDTIME=9999,BMXDTIME(1)=0.5 + I $L(IN,"{BMX}")>2 S CTXT=$E(IN,31+BMXPLEN,9999) + Q + ; +PRSP(PARG) ;EP -Parse Protocol + ;M Extrinsic Function + ; + ;Inputs + ;P Protocol string with the form + ; Protocol := Protocol Header^Message where + ; Protocol Header := LLLWKID;WINH;PRCH;WISH;MESG + ; LLL := length of protocol header (3 numeric) + ; WKID := Workstation ID (ALPHA) + ; WINH := Window handle (ALPHA) + ; PRCH := Process handle (ALPHA) + ; WISH := Window server handle (ALPHA) + ; MESG := Unparsed message + ;Outputs + ;ERR 0 for success, "-1^Text" if error + ; + N ERR,C,M,R,X,P + S P=PARG + S R=0,C=";",ERR=0,M=99999 ;Maximum buffer input + IF $E(P,1,5)="{BMX}" S P=$E(P,6,$L(P)) ;drop out prefix + IF '+$G(P) S ERR="-1^Required input reference is NULL" + IF +ERR=0 D + . S BMXZ(R,"LENG")=+$E(P,1,3) + . S X=$E(P,4,BMXZ(R,"LENG")+3) + . S BMXZ(R,"MESG")=$E(P,BMXZ(R,"LENG")+4,M) + . S BMXZ(R,"WKID")=$P(X,C) + . S BMXZ(R,"WINH")=$P(X,C,2) + . S BMXZ(R,"PRCH")=$P(X,C,3) + . S BMXZ(R,"WISH")=$P(X,C,4) + Q ERR + ; +PRSM(PARG) ;EP - Parse message + ;M Extrinsic Function + ; + ;Inputs + ;P Message string with the form + ; Message := Header^Content + ; Header := LLL;FLAG + ; LLL := length of entire message (3 numeric) + ; FLAG := 1 indicates variables follow + ; Content := Contains API call information + ;Outputs + ;ERR 0 for success, "-1^Text" if error + N C,ERR,M,R,X,U,P + S P=PARG + S U="^",R=1,C=";",ERR=0,M=99999 ;Max buffer + IF '+$G(P) S ERR="-1^Required input reference is NULL" + IF +ERR=0 D + . S BMXZ(R,"LENG")=+$E(P,1,5) + . S BMXZ(R,"FLAG")=$E(P,6,6) + . S BMXZ(R,"TEXT")=$E(P,7,M) + Q ERR + ; +PRSA(P) ;EP - Parse API information, get calling info + ;M Extrinsic Function + ;Inputs + ;P Content := API Name^Param string + ; API := .01 field of API file + ; Param := Parameter information + ;Outputs + ;ERR 0 for success, "-1^Text" if error + ; + N C,DR,ERR,M,R,T,X,U + S U="^",R=2,C=";",ERR=0,M=99999 ;Max buffer + IF '+$L(P) S ERR="-1^Required input reference is NULL" + IF +ERR=0 D + . S BMXZ(R,"CAPI")=$P(P,U) + . S BMXZ(R,"PARM")=$E(P,$F(P,U),M) + . S T=$O(^XWB(8994,"B",BMXZ(R,"CAPI"),0)) + . I '+T S ERR="-1^Remote Procedure '"_BMXZ(R,"CAPI")_"' doesn't exist on the server." Q ;P10 - dpc + . S T(0)=$G(^XWB(8994,T,0)) + . I $P(T(0),U,6)=1!($P(T(0),U,6)=2) S ERR="-1^Remote Procedure '"_BMXZ(R,"CAPI")_"' cannot be run at this time." Q ;P10. Check INACTIVE field. - dpc. + . S BMXZ(R,"NAME")=$P(T(0),"^") + . S BMXZ(R,"RTAG")=$P(T(0),"^",2) + . S BMXZ(R,"RNAM")=$P(T(0),"^",3) + . S BMXPTYPE=$P(T(0),"^",4) + . S BMXWRAP=+$P(T(0),"^",8) + Q ERR + ;information +PRSB(P) ;EP - Parse Parameter + ;M Extrinsic Function + ;Inputs + ;P Param := M parameter list + ; Param := LLL,Name,Value + ; LLL := length of variable name and value + ; Name := name of M variable + ; Value := a string + ;Outputs + ;ERR 0 for success, "-1^Text" if error + ; + ; + N A,ERR,F,FL,I,K,L,M,P1,P2,P3,P4,P5,MAXP,R,Z + S R=3,MAXP=+$E(P,1,5) + S P1=$E(P,6,MAXP+5) ;only param string + S ERR=0,F=3,M=99999 + IF '+$D(P) S ERR="-1^Required input reference is NULL" + S FL=+$G(BMXZ(1,"FLAG")) + S I=0 + IF '+ERR D + . IF 'FL,+MAXP=0 S P1="",ERR=1 Q + . F D Q:P1="" + . . Q:P1="" + . . S L=+$E(P1,1,3)-1 + . . S P3=+$E(P1,4,4) + . . S P1=$E(P1,5,MAXP) + . . S BMXZ(R,"P",I)=$S(P3'=1:$E(P1,1,L),1:$$GETV^BMXMBRK($E(P1,1,L))) + . . IF FL=1,P3=2 D ;XWB*1.1*2 + . . . S A=$$OARY^BMXMBRK2,BMXARY=A + . . . S BMXZ(R,"P",I)=$$CREF^BMXMBRK2(A,BMXZ(R,"P",I)) + . . S P1=$E(P1,L+1,MAXP) + . . S K=I,I=I+1 + . IF 'FL Q + . S P3=P + . S L=+$E(P3,1,5) + . S P1=$E(P3,F+3,L+F) + . S P2=$E(P3,L+F+3,M) + . ;instantiate array + . ;0011400 + . S Z=$P(P,".x",2,99) + . F D Q:+L=0 + . . S L=+$E(Z,1,3) + . . S P3=+$E(Z,4,3+L) + . . S L1=+$E(Z,L+4,L+6) + . . S P4=$E(Z,L+7,L+6+L1) + . . ; S L=$$BREAD(3) Q:+L=0 S P3=$$BREAD(L) + . . ; S L=$$BREAD(3) IF +L'=0 S P4=$$BREAD(L) + . . IF +L=0 Q + . . IF P3=0,P4=0 S L=0 Q + . . IF FL=1 D LINST^BMXMBRK(A,P3,P4) + . . S Z=$E(Z,L+7+L1,99999) + IF ERR Q P1 + S P1="" + F I=0:1:K D + . IF FL,$E(BMXZ(R,"P",I),1,5)=".BMXS" D Q ;XWB*1.1*2 + .. S P1=P1_"."_$E(BMXZ(R,"P",I),2,$L(BMXZ(R,"P",I))) + .. IF I'=K S P1=P1_"," + .. Q + . S P1=P1_"BMXZ("_R_",""P"","_I_")" + . IF I'=K S P1=P1_"," + . Q + IF '+ERR Q P1 + Q ERR + ; +CALLP(BMXP,P,BMXSTR,DEBUG) ;EP - make API call using Protocol string + N ERR,S + S ERR=0,BMXSTR="" + K BMXSEC + IF '$D(DEBUG) S DEBUG=0 + S ERR=$$PRSP(P) + IF '+ERR S ERR=$$PRSM(BMXZ(0,"MESG")) + IF '+ERR S ERR=$$PRSA(BMXZ(1,"TEXT")) ;I $G(BMXZ(2,"CAPI"))="XUS SET SHARED" S XWBSHARE=1 Q + I +ERR S BMXSEC=$P(ERR,U,2) ;P10 -- dpc + IF '+ERR S S=$$PRSB(BMXZ(2,"PARM")) + ;IF (+S=0)!(+S>0) D + I '+ERR D CHKPRMIT^BMXMSEC(BMXZ(2,"CAPI")) ;checks if RPC allowed to run + S:$L($G(BMXSEC)) ERR="-1^"_BMXSEC + ;IF 'DEBUG S:$D(XRT0) XRTN="RPC BROKER READ/PARSE" D:$D(XRT0) T1^%ZOSV ;stop RTL + IF '+ERR,(+S=0)!(+S>0) D + . D CAPI^BMXMBRK2(.BMXP,BMXZ(2,"RTAG"),BMXZ(2,"RNAM"),S) + IF 'DEBUG K BMXZ + IF $D(BMXARY) K @BMXARY,BMXARY + Q + ; +TEST(OUT,STG,RPT,DELAY) ; + I $L($G(STG)) + E Q + S OUT=$NA(^TMP("BMX DATA",$J)),@OUT@(1)="" + S RPT=+$G(RPT) + I RPT F I=1:1:RPT S STG=STG_STG + H +$G(DELAY) + S OUT=STG + Q + ; Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXFIND.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXFIND.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXFIND.m (revision 1147) @@ -0,0 +1,260 @@ +BMXFIND ; IHS/OIT/HMW - BMX GENERIC FIND ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; +TABLE(BMXGBL,BMXFL) ;EP + ; + ;---> If file number not provided check for file name. + ;S ^HW("BMXTABLE")=BMXFL + S BMX31=$C(31)_$C(31) + I +BMXFL'=BMXFL D + . S BMXFL=$TR(BMXFL,"_"," ") + . I '$D(^DIC("B",BMXFL)) S BMXFL="" Q + . S BMXFL=$O(^DIC("B",BMXFL,0)) + I '$G(BMXFL) D ERROUT("File number not provided.",1) Q + D FIND(.BMXGBL,BMXFL,"*",,,10,,,,1) + Q + ; +FIND(BMXGBL,BMXFL,BMXFLDS,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,BMXMC,BMXNUM) ;EP + ; + ;TODO: + ; -- Return column info even if no rows returned + ; + ;---> Places matching records from requested file into a + ;---> result global, ^BMXTEMP($J). The exact global name + ;---> is returned in the first parameter (BMXGBL). + ;---> Records are returned one per node in the result global. + ;---> Each record is terminated with a $C(30), for parsing out + ;---> on the VB side, since the Broker concatenates all nodes + ;---> into a single string when passing the data out of M. + ;---> Requested fields within records are delimited by "^". + ;---> NOTE: The first "^"-piece of every node is the IEN of + ;---> that entry in its file; the requested fields follow. + ;---> The final record (node) contains Error Delimiter, + ; $C(31)_$C(31), followed by error text, if any. + ; + ; + ;---> Parameters: + ; 1 - BMXGBL (ret) Name of result global for Broker. + ; 2 - BMXFL (req) File for lookup. + ; 3 - BMXFLDS (opt) Fields to return w/each entry. + ; 4 - BMXFLG (opt) Flags in DIC(0); If null, "M" is sent. + ; 5 - BMXIN (opt) Input to match on (see Algorithm below). + ; 6 - BMXMX (opt) Maximum number of entries to return. + ; 7 - BMXIX (opt) Indexes to search. + ; 8 - BMXSCR (opt) Screen/filter (M code). + ; 9 - BMXMC (opt) Mixed Case: 1=mixed case, 0=no change. + ; (Converts data in uppercase to mixed case.) + ; 10 - BMXNUM (opt) Include IEN in returned recordset (1=true) + ; + ;---> Set variables, kill temp globals. + ;N (BMXGBL,BMXFL,BMXFLDS,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,BMXMC) + S BMX31=$C(31)_$C(31) + S BMXGBL="^BMXTEMP("_$J_")",BMXERR="",U="^" + K ^BMXTMP($J),^BMXTEMP($J) + ; + ;---> If file number not provided check for file name. + I +BMXFL'=BMXFL D + . I '$D(^DIC("B",BMXFL)) S BMXFL="" Q + . S BMXFL=$O(^DIC("B",BMXFL,0)) + I '$G(BMXFL) D ERROUT("File number not provided.",1) Q + ; + ;---> If no fields provided, pass .01. + ;---> NOTE: If .01 is NOT included, but the Index to lookup on is + ;---> NOT on the .01, then the .01 will be returned + ;---> automatically as the second ^-piece of data in the + ;---> Result Global. + ;---> So it would be: IEN^.01^requested fields... + I $G(BMXFLDS)="" S BMXFLDS=".01" + ; + ;---> If no index or flag provided, set flag="M". + I $G(BMXFLG)="" D + .I $G(BMXIX)="" S BMXFLG="M" Q + .S BMXFLG="" + ; + ;---> If no Maximum Number provided, set it to 200. + I '$G(BMXMX) S BMXMX=200 + ; + ;---> Define index and screen. + S:'$D(BMXIX) BMXIX="" + S:'$D(BMXSCR) BMXSCR="" + ; + ;---> Set Target Global for output and errors. + S BMXG="^BMXTMP($J)" + ; + ;---> If Mixed Case not set, set to No Change. + I '$D(BMXMC) S BMXMC=0 + ; + ;---> If Return IEN not set, set to No + I '$D(BMXNUM) S BMXNUM=0 + S BMXNUM=+BMXNUM + ; + ;---> Silent Fileman call. + D + .I $G(BMXIN)="" D Q + ..D LIST^DIC(BMXFL,,,,BMXMX,0,,BMXIX,BMXSCR,,BMXG,BMXG) + .D FIND^DIC(BMXFL,,,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,,BMXG,BMXG) + ; + D WRITE + Q + ; + ; + ;---------- +WRITE ;EP + ;---> Collect data for matching records and write in result global. + ; + ;---> First, check for errors. + ;---> If errors exist, write them and quit. + N I,N,X + I $D(^BMXTMP($J,"DIERR")) I $O(^("DIERR",0)) D Q + .S N=0,X="" + .F S N=$O(^BMXTMP($J,"DIERR",N)) Q:'N D + ..N M S M=0 + ..F S M=$O(^BMXTMP($J,"DIERR",N,"TEXT",M)) Q:'M D + ...S X=X_^BMXTMP($J,"DIERR",N,"TEXT",M)_" " + .D ERROUT(X,1) + ; + ; + ;---> Write valid results. + ;---> Loop through the IEN node (...2,N) of the temp global. + ; and call GETS^DIQ for each record + N I,N,X S N=0 + S BMXA="A" + ;B + S I=0 + S BMXFLDF=0 +RESULTS F S N=$O(^BMXTMP($J,"DILIST",2,N)) Q:'N D + . S X=^BMXTMP($J,"DILIST",2,N) + . S I=I+1 + . K A + . D GETS^DIQ(BMXFL,X_",",BMXFLDS,,BMXA,BMXA) + . ;--->Once only, write field names + . D:'BMXFLDF FIELDS + . ; + . ; + . ;---> Loop through results global + . S F=0,BMXCNT=0 + . F S F=$O(A(BMXFL,X_",",F)) Q:'F S BMXCNT=BMXCNT+1 + . S F=0 + . S BMXREC="" + . S:BMXNUM ^BMXTEMP($J,I)=X_"^" + . S BMXCNTB=0 + . S BMXORD=BMXNUM + . F S F=$O(A(BMXFL,X_",",F)) Q:'F S BMXCNTB=BMXCNTB+1 D S:BMXCNTBBMXLEN(BMXORD) BMXLEN(BMXORD)=BMXLTMP + . . . . Q + . . . D ;It's a multiple. Implement in next phase + . . . . Q ; + . . . Q + . . E D ;Not a multiple + . . . S I=I+1 + . . . S ^BMXTEMP($J,I)=A(BMXFL,X_",",F) + . . . S:$L(A(BMXFL,X_",",F))>BMXLEN(BMXORD) BMXLEN(BMXORD)=$L(A(BMXFL,X_",",F)) + . . . Q + . . Q + . ;---> Convert data to mixed case if BMXMC=1. + . ;S:BMXMC BMXREC=$$T^BMXTRS(BMXREC) + . ;---> Set data in result global. + . S ^BMXTEMP($J,I)=^BMXTEMP($J,I)_$C(30) + ; + ;---> If no results, report it as an error. + D:'$O(^BMXTEMP($J,0)) + .I BMXIN]"" S BMXERR="No entry matches """_BMXIN_"""." Q + .S BMXERR="Either the lookup file is empty" + .S BMXERR=BMXERR_" or all entries are screened (software error)." + ; + ;---> Tack on Error Delimiter and any error. + S I=I+1 + S ^BMXTEMP($J,I)=BMX31_BMXERR + ;---> Column types and widths + S C=0 + F S C=$O(BMXLEN(C)) Q:'C D + . I BMXLEN(C)>99999 S BMXLEN(C)=99999 + . S ^BMXTEMP($J,C)=BMXTYP(C)_$$NUMCHAR(BMXLEN(C))_^BMXTEMP($J,C) + Q + ; + ; +NUMCHAR(BMXN) ;EP + ;---> Returns Field Length left-padded with 0 + ; + N BMXC + S BMXC="00000"_BMXN + Q $E(BMXC,$L(BMXC)-4,$L(BMXC)) + ; + ;---> Dead code follows + N C,BMXC,F,N,J + S BMXC="" + S N=BMXN + S:N>99999 N=99999 + S:N<0 N=0 + F J=1:1:$L(N) D + . S F=10**(J-1) + . S C=65+(N-((N\(10*F))*(10*F))\F) + . S C=$C(C) + . S BMXC=C_BMXC + S BMXC="AAAAA"_BMXC + Q $E(BMXC,$L(BMXC)-4,$L(BMXC)) + ; + ; +FIELDS ;---> Write Field Names + ;Field name is TAAAAANAME + ;Where T is the field type (T=Text; D=Date) + ; AAAAA is the field size (see NUMCHAR routine) + ; NAME is the field name + S BMXFLDF=1 + K BMXLEN,BMXTYP + D:$D(A) + . I BMXNUM S ^BMXTEMP($J,I)="IEN^",BMXLEN(I)=10,BMXTYP(I)="T",I=I+1 ;TODO: Change from text to number + . S ASDXFNUM=0 + . S BMXIENS=$O(A(BMXFL,0)) + . F S ASDXFNUM=$O(A(BMXFL,BMXIENS,ASDXFNUM)) Q:'ASDXFNUM D + . . S ASDXFNAM=$P(^DD(BMXFL,ASDXFNUM,0),"^") ;Get type here + . . S ASDXFNAM=$TR(ASDXFNAM," ","_") + . . S BMXTYP(I)="T" + . . S BMXLEN(I)=0 ;Start with length zero + . . S:ASDXFNAM="" ASDXFNAM="UNKNOWN"_I + . . S ^BMXTEMP($J,I)=ASDXFNAM_"^" + . . S I=I+1 + . S ^BMXTEMP($J,I-1)=$E(^BMXTEMP($J,I-1),1,$L(^BMXTEMP($J,I-1))-1)_$C(30) + Q + ; + ;---------- +ERROUT(BMXERR,I) ;EP + ;---> Save next line for Error Code File if ever used. + ;---> If necessary, use I>1 to avoid overwriting valid data. + S:'$G(I) I=1 + S ^BMXTEMP($J,I)=BMX31_BMXERR + Q + ; + ; +PASSERR(BMXGBL,BMXERR) ;EP + ;---> If the RPC routine calling the BMX Generic Lookup above + ;---> detects a specific error prior to the call and wants to pass + ;---> that error in the result global rather than a generic error, + ;---> then a call to this function (PASSERR) can be made. + ;---> This call will store the error text passed in the result global. + ;---> The calling routine should then quit (abort its call to the + ;---> BMX Generic Lookup function above). + ; + ;---> Parameters: + ; 1 - BMXGBL (ret) Name of result global for Broker. + ; 2 - BMXERR (req) Text of error to be stored in result global. + ; + S:$G(BMXERR)="" BMXERR="Error not passed (software error)." + ; + N BMX31 S BMX31=$C(31)_$C(31) + K ^BMXTMP($J),^BMXTEMP($J) + S BMXGBL="^BMXTEMP("_$J_")" + S ^BMXTEMP($J,1)=BMX31_BMXERR + Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXG.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXG.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXG.m (revision 1147) @@ -0,0 +1,54 @@ +BMXG ; IHS/OIT/HMW - UTIL: GET DATA ; + ;;4.1000;BMX;;Apr 17, 2011 + ;;Stolen from:* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER * + ; + ; + ;---------- +GET(FILE,Y,PC) ;EP + ;---> Return text of .01 Field of an entry in a file. + ;---> Parameters: + ; 1 - FILE (req) Number corresponding to desired file: + ; 1 = State File, #5 + ; 2 = Community File, #9999999.5 + ; 3 = Employer File, #9999999.75 + ; 4 = Beneficiary File, #9999999.25 + ; 5 = Tribe File, #9999999.03 + ; 6 = Insurer File, #9999999.18 + ; 7 = Suffix File, #9999999.32 + ; 8 = Employer Group Insurance File, #9999999.77 + ; 9 = Medicare Eligible File, #9000003 + ; 10 = Medicaid Eligible File, #9000004 + ; 11 = Private Insurance Eligible File, #9000006 + ; 12 = Patient File, #9000001 + ; 13 = VA Patient File, #2 + ; 14 = Policy Holder File, #9000003.1 + ; 15 = Relationship File, #9999999.36 + ; + ; 2 - Y (req) IEN in the File storing the desired entry. + ; 3 - PC (opt) Piece of 0-Node to return (default=1). + ; If PC=0 return entire 0-node. + ; + Q:($G(Y)'?1N.N) "" + Q:'$G(FILE) "" + S:$G(PC)="" PC=1 S U="^" + ; + D + .I FILE=1 S GLB="^DIC(5,"_Y_",0)" Q + .I FILE=2 S GLB="^AUTTCOM("_Y_",0)" Q + .I FILE=3 S GLB="^AUTNEMPL("_Y_",0)" Q + .I FILE=4 S GLB="^AUTTBEN("_Y_",0)" Q + .I FILE=5 S GLB="^AUTTTRI("_Y_",0)" Q + .I FILE=6 S GLB="^AUTNINS("_Y_",0)" Q + .I FILE=7 S GLB="^AUTTMCS("_Y_",0)" Q + .I FILE=8 S GLB="^AUTNEGRP("_Y_",0)" Q + .I FILE=9 S GLB="^AUPNMCR("_Y_",0)" Q + .I FILE=10 S GLB="^AUPNMCD("_Y_",0)" Q + .I FILE=11 S GLB="^AUPNPRVT("_Y_",0)" Q + .I FILE=12 S GLB="^AUPNPAT("_Y_",0)" Q + .I FILE=13 S GLB="^DPT("_Y_",0)" Q + .I FILE=14 S GLB="^AUPN3PPH("_Y_",0)" Q + .I FILE=15 S GLB="^AUTTRLSH("_Y_",0)" Q + ; + Q:'FILE "" + Q:PC=0 $G(@GLB) + Q $P($G(@GLB),U,PC) Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXGETS.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXGETS.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXGETS.m (revision 1147) @@ -0,0 +1,146 @@ +BMXGETS ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + ;;Horace Whitt + ;;Interface to GETS^DIQ + ; + ;---------- +GETS(BMXGBL,BMXFL,BMXIENS,BMXFLDS,BMXFLG,BMXMC,BMXNUM) ;EP + ;---> The final record (node) contains Error Delimiter, + ; $C(31)_$C(31), followed by error text, if any. + ; + ;---> Parameters: + ; 1 - BMXGBL (ret) Name of result global for Broker. + ; 2 - BMXFL (req) File number for lookup. + ; 3 - BMXFLDS (req) Fields to return w/each entry in IENS format. + ; 4 - BMXFLG (opt) Flags - See GETS^DIQ documentation + ; 9 - BMXMC (opt) Mixed Case: 1=mixed case, 0=no change. + ; (Converts data in uppercase to mixed case.) + ; 6 - BMXNUM (opt) Include IEN as first returned field (1=true) + ; + ;---> Set variables, kill temp globals. + N BMX31 + S BMX31=$C(31)_$C(31) + S BMXGBL="^BMXTEMP("_$J_")",BMXERR="",U="^" + K ^BMXTMP($J),^BMXTEMP($J) + ; + ;---> If file number not provided, return error. + I '$G(BMXFL) D ERROUT("File number not provided.",1) Q + ; + I $G(BMXFLDS)="" S BMXFLDS=".01" + ; + ;---> Set Target Global for output and errors. + S BMXG="^BMXTMP($J)" + ; + ;---> If Mixed Case not set, set to No Change. + I '$D(BMXMC) S BMXMC=0 + ; + ;---> If Return IEN not set, set to No + I '$D(BMXNUM) S BMXNUM=0 + S BMXNUM=+BMXNUM + ; + ;---> Fileman call + D GETS^DIQ(BMXFL,BMXIENS,BMXFLDS,BMXFLG,BMXG,BMXG) + ; + D WRITE + Q + ; + ; + ;---------- +WRITE ;EP + ;---> Collect data for matching records and write in result global. + ; + ;---> First, check for errors. + ;---> If errors exist, write them and quit. + N I,N,X,F,ASDX,ASDC,ASDXFNUM,ASDXFNAM + I $D(^BMXTMP($J,"DIERR")) I $O(^("DIERR",0)) D Q + .S N=0,X="" + .F S N=$O(^BMXTMP($J,"DIERR",N)) Q:'N D + ..N M S M=0 + ..F S M=$O(^BMXTMP($J,"DIERR",N,"TEXT",M)) Q:'M D + ...S X=X_^BMXTMP($J,"DIERR",N,"TEXT",M)_" " + .D ERROUT(X,1) + ; + ; + ;---> Write Field Names + I BMXNUM S $P(ASDX,"^",1)="IEN" + ;F ASDC=1:1:$L(BMXFLDS,";") D + S ASDC=1 + S ASDXFNUM=0 + F S ASDXFNUM=$O(^BMXTMP($J,BMXFL,BMXIENS,ASDXFNUM)) Q:'ASDXFNUM D + . ;S ASDXFNUM=$P(BMXFLDS,";",ASDC) + . S ASDXFNAM=$P(^DD(BMXFL,ASDXFNUM,0),"^") + . S:ASDXFNAM="" ASDXFNAM="UNKNOWN"_ASDC + . S $P(ASDX,"^",ASDC+BMXNUM)=ASDXFNAM + . S ASDC=ASDC+1 + S ^BMXTEMP($J,1)=ASDX_$C(30) + ;---> Write valid results. +AAA ;---> Loop through results global + S I=2,N=0 F S N=$O(^BMXTMP($J,BMXFL,N)) Q:'N D + . S X="",F=0 + . I BMXNUM S X=+N + . F S F=$O(^BMXTMP($J,BMXFL,N,F)) Q:'F D + . . S:X'="" X=X_U + . . I $P(^DD(BMXFL,F,0),U,2) D I 1 ;Multiple or WP + . . . ;Get the subfile number into FL1 + . . . S FL1=+$P(^DD(BMXFL,F,0),U,2) + . . . S FLD1=$O(^DD(FL1,0)) + . . . I $P(^DD(FL1,FLD1,0),U,2)["W" D ;WP + . . . . S WPL=0 F S WPL=$O(^BMXTMP($J,BMXFL,N,F,WPL)) Q:'WPL D + . . . . . S X=X_^BMXTMP($J,BMXFL,N,F,WPL)_" " + . . . . . Q + . . . . Q + . . . D ;It's a multiple. Implement in next phase + . . . . Q ; + . . . Q + . . E D ;Not a multiple + . . . S X=X_^BMXTMP($J,BMXFL,N,F) + . . . Q + . . Q + . ;---> Convert data to mixed case if BMXMC=1. +ZZZ . S:BMXMC X=$$T^BMXTRS(X) + . ; + . ;---> Set data in result global. + . S ^BMXTEMP($J,I)=X_$C(30) + . S I=I+1 + ; + ;---> If no results, report it as an error. + D:'$O(^BMXTEMP($J,0)) + .I BMXIN]"" S BMXERR="No entry matches """_BMXIN_"""." Q + .S BMXERR="Either the lookup file is empty" + .S BMXERR=BMXERR_" or all entries are screened (software error)." + ; + ;---> Tack on Error Delimiter and any error. + S ^BMXTEMP($J,I)=BMX31_BMXERR + Q + ; + ; + ;---------- +ERROUT(BMXERR,I) ;EP + ;---> Save next line for Error Code File if ever used. + ;---> If necessary, use I>1 to avoid overwriting valid data. + S:'$G(I) I=1 + S ^BMXTEMP($J,I)=BMX31_BMXERR + Q + ; + ; +PASSERR(BMXGBL,BMXERR) ;EP + ;---> If the RPC routine calling the BMX Generic Lookup above + ;---> detects a specific error prior to the call and wants to pass + ;---> that error in the result global rather than a generic error, + ;---> then a call to this function (PASSERR) can be made. + ;---> This call will store the error text passed in the result global. + ;---> The calling routine should then quit (abort its call to the + ;---> BMX Generic Lookup function above). + ; + ;---> Parameters: + ; 1 - BMXGBL (ret) Name of result global for Broker. + ; 2 - BMXERR (req) Text of error to be stored in result global. + ; + S:$G(BMXERR)="" BMXERR="Error not passed (software error)." + ; + N BMX31 S BMX31=$C(31)_$C(31) + K ^BMXTMP($J),^BMXTEMP($J) + S BMXGBL="^BMXTEMP("_$J_")" + S ^BMXTEMP($J,1)=BMX31_BMXERR + Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXMBRK.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXMBRK.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXMBRK.m (revision 1147) @@ -0,0 +1,217 @@ +BMXMBRK ; IHS/OIT/HMW - BMXNet MONITOR ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; +PRSP(P) ;EP -Parse Protocol + ;M Extrinsic Function + ; + ;Inputs + ;P Protocol string with the form + ; Protocol := Protocol Header^Message where + ; Protocol Header := LLLWKID;WINH;PRCH;WISH;MESG + ; LLL := length of protocol header (3 numeric) + ; WKID := Workstation ID (ALPHA) + ; WINH := Window handle (ALPHA) + ; PRCH := Process handle (ALPHA) + ; WISH := Window server handle (ALPHA) + ; MESG := Unparsed message + ;Outputs + ;ERR 0 for success, "-1^Text" if error + ; + N ERR,C,M,R,X + S R=0,C=";",ERR=0,M=512 ;Maximum buffer input + IF $E(P,1,5)="{BMX}" S P=$E(P,6,$L(P)) ;drop out prefix + IF '+$G(P) S ERR="-1^Required input reference is NULL" + IF +ERR=0 D + . S BMXZ(R,"LENG")=+$E(P,1,3) + . S X=$E(P,4,BMXZ(R,"LENG")+3) + . S BMXZ(R,"MESG")=$E(P,BMXZ(R,"LENG")+4,M) + . S BMXZ(R,"WKID")=$P(X,C) + . S BMXZ(R,"WINH")=$P(X,C,2) + . S BMXZ(R,"PRCH")=$P(X,C,3) + . S BMXZ(R,"WISH")=$P(X,C,4) + Q ERR + ; +PRSM(P) ;EP - Parse message + ;M Extrinsic Function + ; + ;Inputs + ;P Message string with the form + ; Message := Header^Content + ; Header := LLL;FLAG + ; LLL := length of entire message (3 numeric) + ; FLAG := 1 indicates variables follow + ; Content := Contains API call information + ;Outputs + ;ERR 0 for success, "-1^Text" if error + N C,ERR,M,R,X,U + S U="^",R=1,C=";",ERR=0,M=512 ;Max buffer + IF '+$G(P) S ERR="-1^Required input reference is NULL" + IF +ERR=0 D + . S BMXZ(R,"LENG")=+$E(P,1,5) + . S BMXZ(R,"FLAG")=$E(P,6,6) + . S BMXZ(R,"TEXT")=$E(P,7,M) + Q ERR + ; +PRSA(P) ;EP - Parse API information, get calling info + ;M Extrinsic Function + ;Inputs + ;P Content := API Name^Param string + ; API := .01 field of API file + ; Param := Parameter information + ;Outputs + ;ERR 0 for success, "-1^Text" if error + ; + N C,DR,ERR,M,R,T,X,U + S U="^",R=2,C=";",ERR=0,M=512 ;Max buffer + IF '+$L(P) S ERR="-1^Required input reference is NULL" + IF +ERR=0 D + . S BMXZ(R,"CAPI")=$P(P,U) + . S BMXZ(R,"PARM")=$E(P,$F(P,U),M) + . S T=$O(^XWB(8994,"B",BMXZ(R,"CAPI"),0)) + . I '+T S ERR="-1^Remote Procedure '"_BMXZ(R,"CAPI")_"' doesn't exist on the server." Q ;P10 - dpc + . S T(0)=$G(^XWB(8994,T,0)) + . I $P(T(0),U,6)=1!($P(T(0),U,6)=2) S ERR="-1^Remote Procedure '"_BMXZ(R,"CAPI")_"' cannot be run at this time." Q ;P10. Check INACTIVE field. - dpc. + . S BMXZ(R,"NAME")=$P(T(0),"^") + . S BMXZ(R,"RTAG")=$P(T(0),"^",2) + . S BMXZ(R,"RNAM")=$P(T(0),"^",3) + . S BMXPTYPE=$P(T(0),"^",4) + . S BMXWRAP=+$P(T(0),"^",8) + Q ERR + ;information +PRSB(P) ;EP - Parse Parameter + ;M Extrinsic Function + ;Inputs + ;P Param := M parameter list + ; Param := LLL,Name,Value + ; LLL := length of variable name and value + ; Name := name of M variable + ; Value := a string + ;Outputs + ;ERR 0 for success, "-1^Text" if error + ; + N A,ERR,F,FL,I,K,L,M,P1,P2,P3,P4,P5,MAXP,R + S R=3,MAXP=+$E(P,1,5) + S P1=$E(P,6,MAXP+5) ;only param string + S ERR=0,F=3,M=512 + IF '+$D(P) S ERR="-1^Required input reference is NULL" + S FL=+$G(BMXZ(1,"FLAG")) + S I=0 + IF '+ERR D + . IF 'FL,+MAXP=0 S P1="",ERR=1 Q + . F D Q:P1="" + . . Q:P1="" + . . S L=+$E(P1,1,3)-1 + . . S P3=+$E(P1,4,4) + . . S P1=$E(P1,5,MAXP) + . . S BMXZ(R,"P",I)=$S(P3'=1:$E(P1,1,L),1:$$GETV($E(P1,1,L))) + . . IF FL=1,P3=2 D ;XWB*1.1*2 + . . . S A=$$OARY^BMXMBRK2,BMXARY=A + . . . S BMXZ(R,"P",I)=$$CREF^BMXMBRK2(A,BMXZ(R,"P",I)) + . . S P1=$E(P1,L+1,MAXP) + . . S K=I,I=I+1 + . IF 'FL Q + . S P3=P + . S L=+$E(P3,1,5) + . S P1=$E(P3,F+3,L+F) + . S P2=$E(P3,L+F+3,M) + . ;instantiate array + . F D Q:+L=0 + . . S L=$$BREAD(3) Q:+L=0 S P3=$$BREAD(L) + . . S L=$$BREAD(3) IF +L'=0 S P4=$$BREAD(L) + . . IF +L=0 Q + . . IF P3=0,P4=0 S L=0 Q + . . IF FL=1 D LINST(A,P3,P4) + . . IF FL=2 D GINST + IF ERR Q P1 + S P1="" + D Q P1 + . F I=0:1:K D + . . IF FL,$E(BMXZ(R,"P",I),1,5)=".BMXS" D Q ;XWB*1.1*2 + . . . S P1=P1_"."_$E(BMXZ(R,"P",I),2,$L(BMXZ(R,"P",I))) + . . . IF I'=K S P1=P1_"," + . . S P1=P1_"BMXZ("_R_",""P"","_I_")" + . . IF I'=K S P1=P1_"," + IF '+ERR Q P1 + Q ERR + ; +BREAD(L) ;read tcp buffer, L is length + N E,X,DONE + S (E,DONE)=0 + R X#L:BMXDTIME(1) ;IHS/OIT/HMW SAC Exemption Applied For + S E=X + IF $L(E)0) D + I '+ERR D CHKPRMIT^BMXMSEC(BMXZ(2,"CAPI")) ;checks if RPC allowed to run + S:$L($G(BMXSEC)) ERR="-1^"_BMXSEC + ;IF 'DEBUG S:$D(XRT0) XRTN="RPC BROKER READ/PARSE" D:$D(XRT0) T1^%ZOSV ;stop RTL + IF '+ERR,(+S=0)!(+S>0) D + . D CAPI^BMXMBRK2(.BMXP,BMXZ(2,"RTAG"),BMXZ(2,"RNAM"),S) + E D CLRBUF ;p10 + IF 'DEBUG K BMXZ + IF $D(BMXARY) K @BMXARY,BMXARY + Q + ; +LINST(A,X,BMXY) ;instantiate local array + IF BMXY=$C(1) S BMXY="" + S X=A_"("_X_")" + S @X=BMXY + Q +GINST ;instantiate global + N DONE,N,T,T1 + S (DONE,I)=0 + ;find piece with global ref - recover $C(44) + S REF=$TR(REF,$C(23),$C(44)) + F D Q:DONE + . S N=$NA(^TMP("BMXZ",$J,$P($H,",",2))) + . S BMXZ("FRM")=REF + . S BMXZ("TO")=N + . IF '$D(@N) S DONE=1 Q + ;loop through all and instantiate + S DONE=0 + F D Q:DONE + . S T=$E(@REF@(I),4,M) + . IF T="" S DONE=1 Q + . S @N@("BMXZ")="" ;set naked indicator + . S @T + . S I=I+1 + K @N@("BMXZ") + Q + ; +GETV(V) ;get value of V - reference parameter + N X + S X=V + IF $E(X,1,2)="$$" Q "" + IF $C(34,36)[$E(V) X "S V="_$$VCHK(V) + E S V=@V + Q V + ; +VCHK(S) ;Parse string for first argument + N C,I,P + F I=1:1 S C=$E(S,I) D VCHKP:C="(",VCHKQ:C=$C(34) Q:" ,"[C + Q $E(S,1,I-1) +VCHKP S P=1 ;Find closing paren + F I=I+1:1 S C=$E(S,I) Q:P=0!(C="") I "()"""[C D VCHKQ:C=$C(34) S P=P+$S("("[C:1,")"[C:-1,1:0) + Q +VCHKQ ;Find closing quote + F I=I+1:1 S C=$E(S,I) Q:C=""!(C=$C(34)) + Q +CLRBUF ;p10 Empties Input buffer + N % + F R %#1:BMXDTIME(1) Q:%="" ;IHS/OIT/HMW SAC Exemption Applied For + Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXMBRK2.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXMBRK2.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXMBRK2.m (revision 1147) @@ -0,0 +1,170 @@ +BMXMBRK2 ;IHS/OIT/HMW - BMXNet MONITOR ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; +CAPI(BMXY,TAG,NAM,PAR) ;EP - make API call + N R,T,DX,DY + IF BMXZ(1,"FLAG")=2 D + . S PAR=$P(PAR,BMXZ("FRM"))_BMXZ("TO")_$P(PAR,BMXZ("FRM"),2) + S R=$S(PAR'=+PAR&(PAR=""):TAG_"^"_NAM_"(.BMXY)",1:TAG_"^"_NAM_"(.BMXY,"_PAR_")") + U IO + D @R + U $P + Q + ; +BHDR(WKID,WINH,PRCH,WISH) ;Build a protocol header + N S,L + S S="" + S S=WKID_";"_WINH_";"_PRCH_";"_WISH_";" + S L=$L(S) + S S=$E("000"_L,$L(L)+1,$L(L)+3)_S + Q S + ; +BARY(A,R,V) ;add array elements+values to storage array + IF A'["BMXS" Q "-1^ARRAY NAME MUST BE BMXS" + S @A@(R)=V + Q 0 + ; +BLDB(P) ;Build formatted string + N L + S L=$L(P) + Q $E("000"_L,$L(L)+1,$L(L)+3)_P + ; +BLDA(N,P) ;Build API string + ;M Extrinsic Function + ;Inputs + ;N API name + ;P Comma delimited parameter string + ;Outputs + ;String API string if successful, "-1^Text" if error + ; + N I,F,L,T,U,T1,T2 + IF '+$D(N) Q "-1^Required input reference is NULL" + S U="^" + S (F,T,Y)=0 + IF '$D(P) S P="" + IF P'="" D + . S L=$L(P)-$L($TR(P,$C(44)))+1 + . IF L=0 S L=1 + . F I=1:1:L D Q:T + . . S T1=$P(P,",",I) + . . S T2=$E(T1,1,1)="." + . . IF T1=+T1 Q + . . IF $E(T1,1,1)="^" S F=2,T=1 Q + . . IF T2&($E(T1,2,$L(T1))?.ANP) S F=1,T=1 Q + S P=$$BLDB(P) + S L=$L(P)+$L(P)-3 + S P=F_N_U_P + S L=$L(P) + Q $E("000"_L,$L(L)+1,$L(L)+3)_P + ; +BLDS(R) ;Build a parameter string from an array + N L,T,Y + S Y="" + F D Q:R="" + . S R=$Q(@R) + . IF R="" Q + . S L=$L(R)+$L(@R)+1 + . S T=@R + . S T=$TR(T,$C(44),$C(23)) + . S Y=Y_$E("000"_L,$L(L)+1,$L(L)+3)_R_"="_T + Q Y_"000" + ; +BLDU(R) ;Build a parameter string from a scalar + N DONE,L,N,N1,P1 + IF R=+R Q R + S N=$F(R,$C(34)) + IF N=0 Q $C(34)_R_$C(34) + S P1=$E(R,1,N-2) + S (L,DONE)=0 + F D Q:DONE + . S N1=$F(R,$C(34),N) + . IF N1=0 S L=$L(R)+2,N1=L + . S P1=P1_$C(34,34)_$E(R,N,N1-2) + . IF N1=L S DONE=1,P1=$C(34)_P1_$C(34) Q + . S N=N1 + Q $TR(P1,$C(44),$C(23)) + ; +BLDG(R) ;build a parameter string from a global reference + N I,L,L1,M,T,T1,T2,Y + K ^TMP("BMXZ",$J) + IF '$D(R) Q "-1^Reference does not exist" + S Y=$NA(^TMP("BMXZ",$J,$P($H,",",2))) + S I=0 + S M=512 + S T1=$P(R,")") + S L1=$L($P(R,"(")) + F D Q:R="" + . S R=$Q(@R) + . S T2=$F(R,"(") + . IF R=""!(R'[T1) Q + . S L=$L(R)+$L(@R)-L1 + . S T=@R + . S T=$TR(T,$C(44),$C(23)) + . S @Y@(I)=$E("000"_L,$L(L)+1,$L(L)+3)_U_"("_$E(R,T2,M)_"="_$$BLDU(T) + . S I=I+1 + S @Y@(I)="000" + S Y=$TR(Y,$C(44),$C(23)) + Q Y + ; +OARY() ;EP - create storage array + N A,DONE,I + S (DONE,I)=0 + F I=1:1 D Q:DONE + . S A="BMXS"_I + . K @A ;temp fix for single array + . IF '$D(@A) S DONE=1 + S @A="" ;set naked + Q A + ; +CREF(R,P) ;EP - Convert array contained in P to reference A + N I,X,DONE,F1,S + S DONE=0 + S S="" + F I=1:1 D Q:DONE + . IF $P(P,",",I)="" S DONE=1 Q + . S X(I)=$P(P,",",I) + . IF X(I)?1"."1A.E D + . . S F1=$F(X(I),".") + . . S X(I)="."_R + . S S=S_X(I)_"," + Q $E(S,1,$L(S)-1) + ; +GETP(P) ;returns various parameters out of the Protocol string + N M,T,BMXZ + S M=512 + S T=$$PRSP^BMXMBRK(P) + IF '+T D + . S T=$$PRSM^BMXMBRK(BMXZ(0,"MESG")) + . IF '+T S T=BMXZ(0,"WKID")_";"_BMXZ(0,"WINH")_";"_BMXZ(0,"PRCH")_";"_BMXZ(0,"WISH")_";"_$P(BMXZ(1,"TEXT"),"^") + Q T + ; +CALLM(X,P,DEBUG) ;make call using Message string + N ERR,S + S X="",ERR=0 + S ERR=$$PRSM^BMXMBRK(P) + IF '+ERR S ERR=$$PRSA^BMXMBRK(BMXZ(1,"TEXT")) + IF '+ERR S S=$$PRSB^BMXMBRK(BMXZ(2,"PARM")) + IF (+S=0)!(+S>0) D + . D CAPI(.X,BMXZ(2,"RTAG"),BMXZ(2,"RNAM"),S) + IF 'DEBUG K BMXZ + K @(X("BMXS")),X("BMXS") + Q + ; +CALLA(X,P,DEBUG) ;make call using API string + N ERR,S + S X="",ERR=0 + S ERR=$$PRSA^BMXMBRK(P) + IF '+ERR S S=$$PRSB^BMXMBRK(BMXZ(2,"PARM")) + IF (+S=0)!(+S>0) D + . D CAPI(.X,BMXZ(2,"RTAG"),BMXZ(2,"RNAM"),S) + IF 'DEBUG K BMXZ + K @(X("BMXS")),X("BMXS") + Q + ; +TRANSPRT() ;Determine the Transport Method + ;DDP is local :=0 + ;TCP/IP is remote :=1 + ;Serial/RS-232 is remote :=2 + Q 1 + ;Q 0 ;Do DDP for Now Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXMEVN.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXMEVN.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXMEVN.m (revision 1147) @@ -0,0 +1,268 @@ +BMXMEVN ; IHS/OIT/HMW - BMXNet MONITOR ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + Q + ; +REGET ;EP + ;Error trap from REGEVNT, RAISEVNT, and UNREG + ; + I '$D(BMXI) N BMXI S BMXI=999 + S BMXI=BMXI+1 + D REGERR(BMXI,99) + Q + ; +REGERR(BMXI,BMXERID) ;Error processing + S BMXI=BMXI+1 + S ^TMP("BMX",$J,BMXI)=BMXERID_$C(30) + S BMXI=BMXI+1 + S ^TMP("BMX",$J,BMXI)=$C(31) + Q + ; +REGEVNT(BMXY,BMXEVENT) ;EP + ;RPC Called by BMX REGISTER EVENT to inform RPMS server + ;of client's interest in BMXEVENT + ;Returns RECORDSET with field ERRORID. + ;If everything ok then ERRORID = 0; + ; + N BMXI + S BMXI=0 + S X="REGET^BMXMEVN",@^%ZOSF("TRAP") + S BMXY=$NA(^TMP("BMX",$J)) K @BMXY + S ^TMP("BMX",$J,0)="I00020ERRORID"_$C(30) + S ^TMP("BMX EVENT",$J,BMXEVENT)=$G(DUZ) + ; + S BMXI=BMXI+1 + S ^TMP("BMX",$J,BMXI)="0"_$C(30)_$C(31) + Q + ; +RAISEVNT(BMXY,BMXEVENT,BMXPARAM,BMXBACK,BMXKEY) ;EP + ;RPC Called to raise event BMXEVENT with parameter BMXPARAM + ;If BMXBACK = 'TRUE' then event will be raised back to originator + ;Calls EVENT + ;Returns a RECORDSET wit the field ERRORID. + ;If everything ok then ERRORID = 0; + ; + N BMXI,BMXORIG + S BMXI=0 + S BMXORIG=$S($G(BMXBACK)="TRUE":"",1:$J) + S BMXY=$NA(^TMP("BMX",$J)) K @BMXY + S ^TMP("BMX",$J,0)="I00020ERRORID"_$C(30) + S X="REGET^BMXMEVN",@^%ZOSF("TRAP") + ; + D EVENT(BMXEVENT,BMXPARAM,BMXORIG,$G(BMXKEY)) + ; + S BMXI=BMXI+1 + S ^TMP("BMX",$J,BMXI)="0"_$C(30)_$C(31) + Q + ; +EVENT(BMXEVENT,BMXPARAM,BMXORIG,BMXKEY) ;PEP - Raise event to interested clients + ;Clients are listed in ^TMP("BMX EVENT",BMXEVENT,BMXSESS)=DUZ + ;BMXORIG represents the event originator's session + ;The event will not be raised back to the originator if BMXORIG is the session of the originator + ;BMXKEY is a ~-delimited list of security keys. Only holders of one of these keys + ;will receive event notification. If BMXKEY is "" then all registered sessions + ;will be notified. + ; + L +^TMP("BMX EVENT RAISED"):30 + N BMXSESS,BMXINC + S BMXSESS=0 F S BMXSESS=$O(^TMP("BMX EVENT",BMXSESS)) Q:'+BMXSESS D + . I BMXSESS=$G(BMXORIG) Q + . I '$D(^TMP("BMX EVENT",BMXSESS,BMXEVENT)) Q + . ;S BMXDUZ=^TMP("BMX EVENT",BMXEVENT,BMXSESS) + . S BMXDUZ=^TMP("BMX EVENT",BMXSESS,BMXEVENT) + . ;TODO: Test if DUZ holds at least one of the keys in BMXKEY + . S BMXINC=$O(^TMP("BMX EVENT RAISED",BMXSESS,BMXEVENT,99999999),-1) + . S:BMXINC="" BMXINC=0 + . ;S ^TMP("BMXTRACK",$P($H,",",2))="Job "_$J_" Set "_$NA(^TMP("BMX EVENT RAISED",BMXSESS,BMXEVENT,BMXINC+1))_"="_$G(BMXPARAM) + . S ^TMP("BMX EVENT RAISED",BMXSESS,BMXEVENT,BMXINC+1)=$G(BMXPARAM) ;IHS/OIT/HMW SAC Exemption Applied For + . Q + L -^TMP("BMX EVENT RAISED") + Q + ; +POLLD(BMXY) ;EP + ;Debug Entry Point + ;D DEBUG^%Serenji("POLLD^BMXMEVN(.BMXY)") + Q + ; +POLL(BMXY) ;EP + ;Check event queue for events of interest to current session + ;Return DataSet of events and parameters + ;Called by BMX EVENT POLL + ; + N BMXI,BMXEVENT + S BMXI=0 + S X="POLLET^BMXMEVN",@^%ZOSF("TRAP") + S BMXY=$NA(^TMP("BMX",$J)) K @BMXY + S ^TMP("BMX",$J,0)="T00030EVENT"_U_"T00030PARAM"_$C(30) + L +^TMP("BMX EVENT RAISED"):1 G:'$T POLLEND + ; + G:'$D(^TMP("BMX EVENT RAISED",$J)) POLLEND + S BMXEVENT=0 F S BMXEVENT=$O(^TMP("BMX EVENT RAISED",$J,BMXEVENT)) Q:BMXEVENT']"" D + . N BMXINC + . S BMXINC=0 + . F S BMXINC=$O(^TMP("BMX EVENT RAISED",$J,BMXEVENT,BMXINC)) Q:'+BMXINC D + . . ;Set output array node + . . S BMXPARAM=$G(^TMP("BMX EVENT RAISED",$J,BMXEVENT,BMXINC)) + . . S BMXI=BMXI+1 + . . S ^TMP("BMX",$J,BMXI)=BMXEVENT_U_BMXPARAM_$C(30) + . . Q + . Q + ;S ^TMP("BMXTRACK",$P($H,",",2))="Job "_$J_" Killed "_$NA(^TMP("BMX EVENT RAISED",$J)) + K ^TMP("BMX EVENT RAISED",$J) + ; +POLLEND S BMXI=BMXI+1 + S ^TMP("BMX",$J,BMXI)=$C(31) + L -^TMP("BMX EVENT RAISED") + Q + ; +TTESTD(BMXY,BMXTIME) ;Debug entry point + ; + ;D DEBUG^%Serenji("TTEST^BMXMEVN(.BMXY,BMXTIME)") + Q + ; +TTEST(BMXY,BMXTIME) ;EP Timer Test + ; + S X="REGET^BMXMEVN",@^%ZOSF("TRAP") + S BMXY=$NA(^BMXTMP("BMX",$J)) K @BMXY + S ^BMXTMP("BMX",$J,0)="I00020HANGTIME"_$C(30) + I +BMXTIME H BMXTIME + ; + S BMXI=1 + S BMXI=BMXI+1 + S ^BMXTMP("BMX",$J,BMXI)=BMXTIME_$C(30)_$C(31) + ; + Q + ; +UNREGALL ;EP + ;Unregister all events for current session + ;Called on exit of each session + ; + N BMXEVENT + S BMXEVENT="" + K ^TMP("BMX EVENT",$J) + Q + ; +UNREG(BMXY,BMXEVENT) ;EP + ;RPC Called by client to Unregister client's interest in BMXEVENT + ;Returns RECORDSET with field ERRORID. + ;If everything ok then ERRORID = 0; + ; + N BMXI + S BMXI=0 + S X="REGET^BMXMEVN",@^%ZOSF("TRAP") + S BMXY=$NA(^TMP("BMX",$J)) K @BMXY + S ^TMP("BMX",$J,0)="I00020ERRORID"_$C(30) + K ^TMP("BMX EVENT",$J,BMXEVENT) + ; + S BMXI=BMXI+1 + S ^TMP("BMX",$J,BMXI)="0"_$C(30)_$C(31) + Q + ; +POLLET ;EP + ;Error trap from REGEVNT, RAISEVNT, ASYNCQUE and UNREG + ; + I '$D(BMXI) N BMXI S BMXI=999 + S BMXI=BMXI+1 + D POLLERR(BMXI,99) + Q + ; +POLLERR(BMXI,BMXERID) ;Error processing + S BMXI=BMXI+1 + S ^TMP("BMX",$J,BMXI)=BMXERID_U_$C(30) + S BMXI=BMXI+1 + S ^TMP("BMX",$J,BMXI)=$C(31) + Q + ; +ASYNCQUD(BMXY,BMXRPC,BMXEVN) ;EP + ;D DEBUG^%Serenji("ASYNCQUD^BMXMEVN(.BMXY,BMXRPC,BMXEVN)") + Q + ; +ASYNCQUE(BMXY,BMXRPC,BMXEVN) ;EP + ;RPC Queues taskman to job wrapper ASYNCZTM + N BMXRPCX + S BMXRPCX=$P(BMXRPC,$C(30)) + ;RETURNS EVENT NAME, ZTSK in PARAM + S X="POLLET^BMXMEVN",@^%ZOSF("TRAP") + S BMXY=$NA(^TMP("BMX ASYNC QUEUE",$J)) K @BMXY + S ^TMP("BMX ASYNC QUEUE",$J,0)="I00030ERRORID"_U_"I00030PARAM"_$C(30) + ; + K BMXSEC + S BMXSEC="" + D CHKPRMIT^BMXMSEC(BMXRPCX) ;checks if RPC allowed to run + N OLDCTXT + I $L($G(BMXSEC)) D + . S OLDCTXT="" + . F S OLDCTXT=$O(XWBSTATE("ALLCTX",OLDCTXT)) Q:'$L($G(OLDCTXT)) D I '$L($G(BMXSEC)) Q + . . D ADDCTXT^BMXMSEC(DUZ,OLDCTXT) + . . D CHKPRMIT^BMXMSEC(BMXRPCX) + . . Q + . Q + I $L($G(BMXSEC)) D Q + . S ^TMP("BMX ASYNC QUEUE",$J,1)=2_U_$G(BMXSEC)_$C(30) ;IHS/OIT/HMW SAC Exemption Applied For + . S ^TMP("BMX ASYNC QUEUE",$J,2)=$C(31) ;IHS/OIT/HMW SAC Exemption Applied For + . Q + ;K ZTSK +CHKOLDOK N ZTSK,ZTRTN,ZTSAVE,ZTDESC,ZTIO,ZTDTH + S ZTRTN="ASYNCZTM^BMXMEVN" + S BMXRPC=$TR(BMXRPC,"~",$C(30)) + S ZTSAVE("BMXRPC")="" + S ZTSAVE("BMXEVN")="" + S ZTDESC="BMX ASYNC JOB" + S ZTIO="",ZTDTH=DT + D ^%ZTLOAD + ;D @ZTRTN ;Debugging call + ; + S ^TMP("BMX ASYNC QUEUE",$J,1)=1_U_$G(ZTSK)_$C(30) + S ^TMP("BMX ASYNC QUEUE",$J,2)=$C(31) + ; + Q + ; +ASYNCZTM ;EP + ;Called by Taskman with BMXRPC and BMXEVN defined to + ; 1) invoke the BMXRPC (RPC NAME^PARAM1^...^PARAMN) + ; 2) when done, raises event BMXEVN with ZTSK^$J in BMXPARAM + ; + N BMXRTN,BMXTAG,BMXRPCD,BMXCALL,BMXJ,BMXY,BMXNOD,BMXY + N BMXT S BMXT=$C(30) + I $E(BMXRPC,1,6)="SELECT" S BMXRPC="BMX SQL"_$C(30)_BMXRPC + S BMXRPCD=$O(^XWB(8994,"B",$P(BMXRPC,BMXT),0)) + S BMXNOD=^XWB(8994,BMXRPCD,0) + S BMXRTN=$P(BMXNOD,U,3) + S BMXTAG=$P(BMXNOD,U,2) + S BMXCALL="D "_BMXTAG_"^"_BMXRTN_"(.BMXY," + F BMXJ=2:1:$L(BMXRPC,BMXT) D + . S BMXCALL=BMXCALL_$C(34)_$P(BMXRPC,BMXT,BMXJ)_$C(34) + . S:BMXJ<$L(BMXRPC,BMXT) BMXCALL=BMXCALL_"," + . Q + S BMXCALL=BMXCALL_")" + X BMXCALL + D EVENT(BMXEVN,$G(ZTSK)_"~"_$P($G(BMXY),U,2),$J,"") + Q + ; + ; + ;Windows event handler: + ;Catches event with ZTSK^DataLocation parameter + ;Matches ZTSK to process that called event + ;Calls ASYNCGET rpc with DATALOCATION parameter + ; +ASYNCGET(BMXY,BMXDATA) ;EP + ;RPC Retrieves data queued by ASYNCZTM + ;by setting BMXY to BMXDATA + ; + S BMXY="^"_BMXDATA + Q + ; +ASYNCET ;EP + ;Error trap from ASYNCQUE + ; + I '$D(BMXI) N BMXI S BMXI=999 + S BMXI=BMXI+1 + D ASYNCERR(BMXI,0) + Q + ; +ASYNCERR(BMXI,BMXERID) ;Error processing + S BMXI=BMXI+1 + S ^TMP("BMX ASYNC QUEUE",$J,BMXI)=BMXERID_U_$C(30) + S BMXI=BMXI+1 + S ^TMP("BMX ASYNC QUEUE",$J,BMXI)=$C(31) + Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXMON.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXMON.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXMON.m (revision 1147) @@ -0,0 +1,444 @@ +BMXMON ; IHS/OIT/HMW - BMXNet MONITOR ; 4/6/11 12:42pm + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; IMPORTANT: Logging is on by default. Set XWBDEBUG=0 to turn it off. + ; + ; Changes for *1000 by WV/SMH (Feb 2 2011) to support GT.M + ; - XINETD entry point for GT.M + ; - Replacement of all W *-3 to W ! + ; - Addition of logging capabilities for analysis + ; - In SESSRES + ; -- Broker Timeout set from Kernel System Parameter Broker Timeout Field + ; -- Process Name now changes to show name in %SS or ZSY + ; + ; + ;IHS/OIT/HMW Patch 1 added validity check for passed-in namespace + ; +STRT(BMXPORT,NS,IS,VB) ;EP + ;Interactive monitor start + ;Optional NS = namespace. If undefined, start in current ns + ;Optional IS = Integrated Security. Default is 1 + ;Optional VB = Verbose. Default is 1 + ; + N Y,BMXNS,BMXWIN + ; + ;Verbose + S BMXVB=$G(VB,1) + ; + ;Check if port already running + I '$$SEMAPHOR(BMXPORT,"LOCK") W:BMXVB "BMXNet Monitor on port "_BMXPORT_" appears to be running already.",! Q + S %=$$SEMAPHOR(BMXPORT,"UNLOCK") + ; + D MARKER(BMXPORT,1) ;record problem marker + ; -- start the monitor + ; + ;Namespace + X ^%ZOSF("UCI") + S BMXNS=$G(NS,$P(Y,",")) + ; + ;Integrated security + S BMXWIN=$G(IS,1) + ; + ;J DEBUG^%Serenji("MON^BMXMON("_BMXPORT_","_BMXNS_","_BMXWIN_")") + J MON^BMXMON(BMXPORT,BMXNS,BMXWIN)::5 I '$T W:BMXVB "Unable to run BMXNet Monitor in background.",! Q ;IHS/OIT/HMW SAC Exemption Applied For + F %=1:1:5 D Q:%=0 + . W:BMXVB "Checking if BMXNet Monitor has started...",! + . H 1 + . S:'$$MARKER(BMXPORT,0) %=0 + I $$MARKER(BMXPORT,0) D + . W:BMXVB !,"BMXNet Monitor could not be started!",! + . W:BMXVB "Check if port "_BMXPORT_" is busy on this CPU.",! + . D MARKER(BMXPORT,-1) ;clear marker + E W:BMXVB "BMXNet Monitor started successfully." + ; + Q + ; +RESTART ;EP + ;Stop and Start all monitors in BMX MONITOR file + ;Called by option BMX MONITOR START + ; + D STOPALL + D STRTALL + Q + ; +STRTALL ;EP + ;Start all monitors in BMX MONITOR file + ; + N BMXIEN + S BMXIEN=0 F S BMXIEN=$O(^BMXMON(BMXIEN)) Q:'+BMXIEN D + . S BMXNOD=$G(^BMXMON(BMXIEN,0)) + . Q:'+BMXNOD + . Q:'+$P(BMXNOD,U,2) + . S BMXWIN=$P(BMXNOD,U,3) + . S BMXNS=$P(BMXNOD,U,4) + . D STRT($P(BMXNOD,U),BMXNS,BMXWIN,0) + . Q + Q + ; +STOPALL ;EP + ;Stop all monitors in BMXNET MONITOR file + ; + N BMXIEN,BMXPORT + S BMXIEN=0 F S BMXIEN=$O(^BMXMON(BMXIEN)) Q:'+BMXIEN D + . S BMXNOD=$G(^BMXMON(BMXIEN,0)) + . Q:'+BMXNOD + . S BMXPORT=+BMXNOD + . D STOP(BMXPORT,0) + Q + ; +STOP(BMXPORT,VB) ;EP Stop monitor on BMXPORT + ;Open a channel to monitor on BMXPORT and send shutdown request + ;Optional VB = Verbose. Default is 1 + ; + N IP,REF,X,DEV + S U="^" D HOME^%ZIS + ; + ;Verbose + S BMXVB=$G(VB,1) + ; + D:BMXVB EN^DDIOL("Stop BMXNet Monitor...") + X ^%ZOSF("UCI") S REF=Y + S IP="0.0.0.0" ;get server IP + IF $G(BMXPORT)="" S BMXPORT=9200 + ; -- make sure the listener is running + I $$SEMAPHOR(BMXPORT,"LOCK") D Q + . S %=$$SEMAPHOR(BMXPORT,"UNLOCK") + . D:BMXVB EN^DDIOL("BMXNet Monitor does not appear to be running.") + ; -- send the shutdown message to the TCP Listener process + D CALL^%ZISTCP("127.0.0.1",BMXPORT) I POP D Q + . S %=$$SEMAPHOR(BMXPORT,"UNLOCK") + . D:BMXVB EN^DDIOL("BMXNet Monitor does not appear to be running.") + U IO + S X=$T(+2),X=$P(X,";;",2),X=$P(X,";") + IF X="" S X=0 + S X=$C($L(X))_X + W "{BMX}00011TCPshutdown",! + R X#3:5 ;IHS/OIT/HMW SAC Exemption Applied For + D CLOSE^%ZISTCP + I X="ack" D:BMXVB EN^DDIOL("BMXNet Monitor has been shutdown.") + E D:BMXVB EN^DDIOL("Shutdown Failed!") + ;change process name + D CHPRN($J) + Q + ; +MON(BMXPORT,NS,IS) ;Monitor port for connection & shutdown requests + ;NS = Namespace to Start monitor + ;IS = 1: Enable integrated security + ; + N BMXDEV,BMXQUIT,BMXDTIME,BMXLEN,BMXACT,BMXWIN,BMXNS + S BMXQUIT=0,BMXDTIME=999999 + ; + ;Set lock + Q:'$$SEMAPHOR(BMXPORT,"LOCK") + ;Clear problem marker + D MARKER(BMXPORT,-1) + ;H 1 + ; + ;Namespace + X ^%ZOSF("UCI") + I $G(NS)="" S BMXNS=$P(Y,",") + E S BMXNS=NS + ; + ;Integrated security + S BMXWIN=$G(IS,1) + ; + ;Open server port; + S BMXDEV="|TCP|"_BMXPORT + C BMXDEV ;IHS/OIT/HMW SAC Exemption Applied For + O BMXDEV:(:BMXPORT:"S"):5 I '$T Q ;IHS/OIT/HMW SAC Exemption Applied For + ; + ;S BMXDTIME(1)=BMXDTIME ; TODO: Set timeouts + S BMXDTIME(1)=.5 ;HMW 20050120 + U BMXDEV + F D Q:BMXQUIT + . R BMXACT#5:BMXDTIME ;Read first 5 chars from TCP buffer, timeout=BMXDTIME ;IHS/OIT/HMW SAC Exemption Applied For + . I BMXACT'="{BMX}" S BMXQUIT=1 Q + . R BMXACT#5:BMXDTIME ;Read next 5 chars - message length ;IHS/OIT/HMW SAC Exemption Applied For + . S BMXLEN=+BMXACT + . R BMXACT#BMXLEN:BMXDTIME ;IHS/OIT/HMW SAC Exemption Applied For + . I $P(BMXACT,"^")="TCPconnect" D Q + . . N BMXNSJ,X,Y,ZCHILD,% + . . S BMXNSJ=$P(BMXACT,"^",2) ;Namespace + . . S BMXNSJ=$P(BMXNSJ,",") + . . I BMXNSJ="" S BMXNSJ=BMXNS + . . S X=BMXNSJ + . . X ^%ZOSF("UCICHECK") I Y=0 S BMXNSJ=BMXNS + . . S STATUS=$S(Y'=0:"CONNECTION OK",1:"CONNECTION FAILED, INVALID NAMESPACE") ; SET CONNECTION STATUS BASED ON NAMESPACE VALIDITY + . . J SESSION^BMXMON(BMXWIN)[BMXNSJ]:(:5:BMXDEV:BMXDEV):5 ;IHS/OIT/HMW SAC Exemption Applied For + . . X ("S ZCHILD="_$C(36,90)_"CHILD") + . . I ZCHILD S ^BMXTMP("CONNECT STATUS",ZCHILD)=STATUS + . . Q + . I $P(BMXACT,"^")="TCPshutdown" S BMXQUIT=1 W "ack",! + S %=$$SEMAPHOR(BMXPORT,"UNLOCK") ; destroy 'running flag' + Q + ; +XINETD ;PEP Directly from xinetd or inetd for GT.M + ; + N XWBDEBUG S XWBDEBUG=$$GET^XPAR("SYS","XWBDEBUG") ; 0 1 2 or 3; depending on the level of verbosity desired. + D:XWBDEBUG LOGSTART^XWBDLOG("XINETD^BMXMON") ; Start Log only if logging + ; + N BMXDEV + S U="^",$ETRAP="D ^%ZTER H" ;Set up the error trap + S $ZT="" ;Clear old trap + ; + ; GT.M specific error and device code; get remove ip address + S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""") + S BMXDEV=$P X "U BMXDEV:(nowrap:nodelimiter:ioerror=""^%ZTER H"")" + S %="",@("%=$ZTRNLNM(""REMOTE_HOST"")") S:$L(%) IO("GTM-IP")=% + ; + ; Read message type + N BMXACT,BMXDTIME + S BMXDTIME=10 ; change in 2.2 instead of 9999999 - initial conn timout + R BMXACT#5:BMXDTIME + ; + D LOG("Read: "_BMXACT) + ; + Q:BMXACT'="{BMX}" ; Not a BMX message - quit. + ; Fall through to below... +GTMLNX ;EP from XWBTCPM for GT.M + ; not implementing NS and integrated authentication + ; Vars: Read timeout, msg len, msg, windows auth, Namespace + N BMXDTIME,BMXLEN,BMXACT,BMXWIN,BMXNS + S BMXNSJ="",BMXWIN=0 ; No NS on GT.M, no Windows Authentication + S BMXDTIME(1)=.5,BMXDTIME=180 ; sign on timeout + R BMXACT#5:BMXDTIME ;Read next 5 chars - message length + ; + D LOG("Read: "_BMXACT) + ; + S BMXLEN=+BMXACT + R BMXACT#BMXLEN:BMXDTIME + ; + D LOG("Read: "_BMXACT) + ; + I $P(BMXACT,"^")="TCPconnect" S ^BMXTMP("CONNECT STATUS",$JOB)="CONNECTION OK" G SESSRES ; <--WARNING: A GOTO + I $P(BMXACT,"^")="TCPshutdown" W "ack",! Q + QUIT ; Should't hit this quit, but just in case + ; +SESSION(BMXWIN) ;EP + ;Start session monitor + ;BMXWIN = 1: Enable integrated security +SESSRES ;EP - reentry point from trap + ; new in 2.2: Use kernel rpc timeout instead of 9999999 + S BMXDTIME(1)=.5,BMXDTIME=$$BAT^XUPARAM + ; + ; Change Process Name (new in 2.2 and 2.3) + ; (GT.M doesn't store the IP in $P, but Cache does. We get GT.M + ; remote process IP from linux env var $REMOTE_HOST) + D:+$G(IO("GTM-IP")) CHPRN("BMX:ip"_$P(IO("GTM-IP"),".",3,4)) ; GT.M + D:+$P CHPRN("BMX:ip_"_$P($P,".",3,4)) ; Cache + ; + ;IHS/OIT/HMW SAC Exemption Applied For + N $ESTACK S $ETRAP="D ETRAP^BMXMON" + S DIQUIET=1,U="^" D DT^DICRW + D UNREGALL^BMXMEVN ;Unregister all events for this session + U $P D SESSMAIN + ;Turn off the error trap for the exit + S $ETRAP="" + I $G(DUZ) D LOGOUT^XUSRB + K BMXR,BMXARY + C $P ;IHS/OIT/HMW SAC Exemption Applied For + Q + ; +SESSMAIN ; MAIN LOOP!!!!!! + N BMXTBUF + D SETUP^BMXMSEC(.RET) ;Setup required system vars + S U="^" + U $P + F D Q:BMXTBUF="#BYE#" + . R BMXTBUF#11:BMXDTIME IF '$T D TIMEOUT S BMXTBUF="#BYE#" Q ;IHS/OIT/HMW SAC Exemption Applied For + . ; + . D LOG("Read: "_BMXTBUF) + . ; + . I BMXTBUF="#BYE#" QUIT ;**QUITTING HERE** + . S BMXHTYPE=$S($E(BMXTBUF,1,5)="{BMX}":1,1:0) ;check HDR + . I 'BMXHTYPE S BMXTBUF="#BYE#" D QUIT ;;***QUITTING HERE*** + . . D SNDERR + . . W BMXTBUF,$C(4),! + . . D LOG("Write: "_BMXTBUF_$C(4)_"(flush)") + . S BMXTLEN=$E(BMXTBUF,6,10),L=$E(BMXTBUF,11,11) + . R BMXTBUF#4:BMXDTIME(1) + . ; + . D LOG("Read: "_BMXTBUF) + . ; + . S BMXTBUF=L_BMXTBUF ;IHS/OIT/HMW SAC Exemption Applied For + . S BMXPLEN=BMXTBUF + . R BMXTBUF#BMXPLEN:BMXDTIME(1) ;IHS/OIT/HMW SAC Exemption Applied For + . ; + . D LOG("Read: "_BMXTBUF) + . ; + . I $P(BMXTBUF,U)="TCPconnect" D QUIT ;;***QUIT HERE*** + . . D SNDERR + . . W "accept",$C(4),! ;Ack + . . ; + . . D LOG("Write: accept"_$C(4)_"(flush)") + . . ; + . IF BMXHTYPE D + . . K BMXR,BMXARY + . . IF BMXTBUF="#BYE#" D QUIT + . . . D SNDERR + . . . W "#BYE#",$C(4),! + . . . ; + . . . D LOG("Write: #BYE#\4") + . . . ; + . . S BMXTLEN=BMXTLEN-15 + . . D CALLP^BMXMBRK(.BMXR,BMXTBUF) + . . S BMXPTYPE=$S('$D(BMXPTYPE):1,BMXPTYPE<1:1,BMXPTYPE>6:1,1:BMXPTYPE) + . IF BMXTBUF="#BYE#" Q + . U $P + . D SNDERR ;Clears SNDERR parameters + . D SND + . D WRITE($C(4)) W ! ;send eot and flush buffer + . ; + . D LOG("Write: "_$C(4)) + . ; + D UNREGALL^BMXMEVN ;Unregister all events for this session + Q ;End Of Main + ; + ; +SNDERR ;send error information + ;BMXSEC is the security packet, BMXERROR is application packet + N X + S X=$E($G(BMXSEC),1,255) + W $C($L(X))_X W ! + D LOG("Write: "_$C($L(X))_X_"(flush)") + S X=$E($G(BMXERROR),1,255) + W $C($L(X))_X W ! + D LOG("Write: "_$C($L(X))_X_"(flush)") + S BMXERROR="",BMXSEC="" ;clears parameters + Q + ; +WRITE(BMXSTR) ;Write a data string + ; + I $L(BMXSTR)<511 W ! W BMXSTR Q + ;Handle a long string + W ! ;Flush the buffer + F Q:'$L(BMXSTR) W $E(BMXSTR,1,510),! S BMXSTR=$E(BMXSTR,511,99999) + Q +SND ; -- send data for all, Let WRITE sort it out + N I,T + ; + ; -- error or abort occurred, send null + IF $L(BMXSEC)>0 D WRITE(""),LOG("Write Sting.Empty") Q + ; -- single value + IF BMXPTYPE=1 S BMXR=$G(BMXR) D WRITE(BMXR),LOG("Write: "_BMXR) Q + ; -- table delimited by CR+LF + IF BMXPTYPE=2 D Q + . S I="" F S I=$O(BMXR(I)) Q:I="" D WRITE(BMXR(I)),WRITE($C(13,10)),LOG("Write: "_BMXR(I)) + ; -- word processing + IF BMXPTYPE=3 D Q + . S I="" F S I=$O(BMXR(I)) Q:I="" D WRITE(BMXR(I)),LOG("Write: "_BMXR(I)) D:BMXWRAP WRITE($C(13,10)),LOG("Write: "_$C(13,10)) + ; -- global array + IF BMXPTYPE=4 D Q + . S I=$G(BMXR) Q:I="" S T=$E(I,1,$L(I)-1) D:$D(@I)>10 WRITE(@I),LOG("Write: "_@I) + . F S I=$Q(@I) Q:I=""!(I'[T) W ! W @I W:BMXWRAP&(@I'=$C(13,10)) $C(13,10) D LOG("Write: "_@I) + . IF $D(@BMXR) K @BMXR + ; -- global instance + IF BMXPTYPE=5 S BMXR=$G(@BMXR) D WRITE(BMXR),LOG("Write: "_BMXR) Q + ; -- variable length records only good upto 255 char) + IF BMXPTYPE=6 S I="" F S I=$O(BMXR(I)) Q:I="" D WRITE($C($L(BMXR(I)))),WRITE(BMXR(I)),LOG("Write: "_$C($L(BMXR(I)))_BMXR(I)) + Q + ; +TIMEOUT ;Do this on MAIN loop timeout + I $G(DUZ)>0 D SNDERR,WRITE("#BYE#"_$C(4)) Q + ;Sign-on timeout + S BMXR(0)=0,BMXR(1)=1,BMXR(2)="",BMXR(3)="TIME-OUT",BMXPTYPE=2 + D SNDERR,SND,WRITE($C(4)) + Q + ; +SEMAPHOR(BMXTSKT,BMXACT) ;Lock/Unlock BMXMON semaphore + N RESULT + S U="^",RESULT=1 + D GETENV^%ZOSV ;get Y=UCI^VOL^NODE^BOXLOOKUP of current system + I BMXACT="LOCK" D + . L +^BMXMON("BMXMON",$P(Y,U,2),$P(Y,U),$P(Y,U,4),BMXTSKT):1 + . S RESULT=$T + E L -^BMXMON("BMXMON",$P(Y,U,2),$P(Y,U),$P(Y,U,4),BMXTSKT) + Q RESULT + ; +CHPRN(N) ;Change process name to N. + D SETNM^%ZOSV($E(N,1,15)) + Q + ; +CKSTAT(OUT,IN) ; EP - RPC: BMX CONNECT STATUS ; CONFIRMS THAT THAT A VALID PROCESS HAS BEEN SPAWNED BY BMXMON + N PORT,STATUS,JOBID + S PORT=+$P($P,"|",3) + S JOBID=$P($J,":",1) + I $G(^BMXTMP("CONNECT STATUS",JOBID))="" HANG 1 ;Wait for job to spawn ZCHILD to be set in MON^ + I $G(^BMXTMP("CONNECT STATUS",JOBID))="" HANG 1 + I $G(^BMXTMP("CONNECT STATUS",JOBID))="" HANG 1 + S STATUS=$G(^BMXTMP("CONNECT STATUS",JOBID)) + K ^BMXTMP("CONNECT STATUS",JOBID) + I STATUS="" S STATUS="CONNECTION STATUS UNKNOWN" + S OUT=PORT_"|"_STATUS_"|"_JOBID + Q + ; +MARKER(BMXPORT,BMXMODE) ;Set/Test/Clear Problem Marker, BMXMODE=0 is a function + N IP,Y,%,REF X ^%ZOSF("UCI") S REF=Y,IP="0.0.0.0",%=0 + L +^BMX(IP,REF,BMXPORT,"PROBLEM MARKER"):1 + I BMXMODE=1 S ^BMX(IP,REF,BMXPORT,"PROBLEM MARKER")=1 + I BMXMODE=0 S:$D(^BMX(IP,REF,BMXPORT,"PROBLEM MARKER")) %=1 + I BMXMODE=-1 K ^BMX(IP,REF,BMXPORT,"PROBLEM MARKER") + L -^BMX(IP,REF,BMXPORT,"PROBLEM MARKER") + Q:BMXMODE=0 % Q + ; +ETRAP ; -- on trapped error, send error info to client + ; Error Trap Vars: Code, Error, Last Global Reference + N BMXERC,BMXERR,BMXLGR + ; + ;Change trapping during trap. + S $ETRAP="D ^%ZTER HALT" ;IHS/OIT/HMW SAC Exemption Applied For + ; + ; If the error is simply that we can't write to the TCP device + ; clear and log out + ; GT.M Error Code. + I $ECODE=",Z150376602," S $ECODE="" D:$G(DUZ) LOGOUT^XUSRB HALT + ; Cache Error Codes: + I ($EC["READ")!($EC["WRITE")!($EC["SYSTEM-F") S $ECODE="" D:$G(DUZ) LOGOUT^XUSRB HALT + ; + ; Otherwise, log error and send to client + S BMXERC=$$EC^%ZOSV + S BMXERR="M ERROR="_BMXERC_$C(13,10)_"LAST REF=" + S BMXLGR=$$LGR^%ZOSV_$C(4) + S BMXERR=BMXERR_BMXLGR + ; + D ^%ZTER ;%ZTER clears $ZE and $ECODE + ; + U $P + ; + D SNDERR,WRITE(BMXERR) W ! + ; + S $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" G SESSRES^BMXMON",$ECODE=",U99," ;IHS/OIT/HMW SAC Exemption Applied For + QUIT + ; +LOG(STR) ; EP - Log stuff in Broker log only if XWBDLOG is defined + D:XWBDEBUG LOG^XWBDLOG(STR) + QUIT + ; +MENU ;EP - ENTRY ACTION FROM BMXMENU OPTION + ; + N BMX,BMXVER + ;VERSION + D + . S BMXN="BMXNET ADO.NET DATA PROVIDER" I $D(^DIC(9.4,"B",BMXN)) Q + . S BMXN="BMXNET RPMS .NET UTILITIES" I $D(^DIC(9.4,"B",BMXN)) Q + . S BMXN="" + . Q + ; + S BMXVER="" + I BMXN]"",$D(^DIC(9.4,"B",BMXN)) D + . S BMX=$O(^DIC(9.4,"B",BMXN,0)) + . I $D(^DIC(9.4,BMX,"VERSION")) S BMXVER=$P(^DIC(9.4,BMX,"VERSION"),"^") + . E S BMXVER="VERSION NOT FOUND" + S:BMXVER="" BMXVER="VERSION NOT FOUND" + ; + ;LOCATION + N BMXLOC + S BMXLOC="" + I $G(DUZ(2)),$D(^DIC(4,DUZ(2),0)) S BMXLOC=$P(^DIC(4,DUZ(2),0),"^") + S:BMXLOC="" BMXLOC="LOCATION NOT FOUND" + ; + ;WRITE + W ! + W !,"BMXNet Version: ",BMXVER + W !,"Location: ",BMXLOC + Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXMSEC.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXMSEC.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXMSEC.m (revision 1147) @@ -0,0 +1,97 @@ +BMXMSEC ; IHS/OIT/HMW - BMXNet MONITOR ; 4/6/11 4:41pm + ;;4.1000;BMX;;Apr 17, 2011 + ;; + ; Changes by WV/SMH for *1000 (Feb 2 2010) + ; Changes: SETUP now gets GT.M IP depending on ^%ZOSF("OS") + ; --> in IP("GTM-IP") per XWBTCPM model. + ; +CHKPRMID(BMXRP) ;EP - checks to see if remote procedure is permited to run + ;D DEBUG^%Serenji("CHKPRMID^BMXMSEC(BMXRP)") + Q + ; +CHKPRMIT(BMXRP) ;EP - checks to see if remote procedure is permited to run + ;Input: BMXRP - Remote procedure to check + Q:$$KCHK("XUPROGMODE") + N ERR,BMXALLOW + S U="^",BMXSEC="" ;clear + ; + ;In the beginning, when no DUZ is defined and no context exist, setup + ;default signon context + S:'$G(DUZ) DUZ=0,XQY0="XUS SIGNON" ;set up default context + S:'$L($G(XQY0)) XQY0="BMXRPC" + ; + ; Next 2 lines new in BMX 4 + S XWBSTATE("ALLCTX",XQY0)=1 ; LOCAL ARRAY REMEMBERING ALL APPCONTEXTS USED FOR THIS SESSION + I DUZ D ADDCTXT(DUZ,"BMXRPC") ; IN DIRECT MODE, CHECK USER APP CTXT PERMISSION AND, IF NECESSARY, APPEND THE RPC NODES IN ^TMP("XQCS",$J + ; + I BMXRP'="XWB IM HERE",BMXRP'="XWB CREATE CONTEXT",BMXRP'="XUS AV CODE",BMXRP'="XWB RPC LIST",BMXRP'="BMX AV CODE" D ;check exemptions. new exemption for XWB*1.1*6 - dpc + . I $G(XQY0)'="" D + . . S BMXALLOW=$$CHK^XQCS(DUZ,$P(XQY0,U),BMXRP) ;do the check + . . S:'BMXALLOW BMXSEC=BMXALLOW + . E S BMXSEC="Application context has not been created!" + Q + ; +OWNSKEY(RET,LIST) ;EP Does user have Key + N I,K S I="" + I $G(DUZ)'>0 S RET(0)=0 Q + I $O(LIST(""))="" S RET(0)=$$KCHK(LIST) Q + F S I=$O(LIST(I)) Q:I="" S RET(I)=$$KCHK(LIST(I)) + Q +KCHK(%) Q $S($G(DUZ)>0:$D(^XUSEC(%,DUZ)),1:0) ;EP Key Check + ; + ; +SETUP(RET) ;EP - sets up environment for GUI signon + ; + K ^TMP("XQCS",$J) + S:^%ZOSF("OS")["GT.M" IO("IP")=IO("GTM-IP") + S:^%ZOSF("OS")["OpenM" IO("IP")=$P + D ZIO^%ZIS4 ;IHS/OIT/HMW SAC Exemption Applied For + D SET1(0),SET^BMXMSEC("XUS XOPT",XOPT),SET^BMXMSEC("XUS CNT",0) + S %ZIS="0H",IOP="NULL" D ^%ZIS + ;0=server name, 1=volume, 2=uci, 3=device, 4=# attempts, 5=skip signon-screen + S RET(0)=$P(XUENV,U,3),RET(1)=$P(XUVOL,U),RET(2)=XUCI + S RET(3)=$I,RET(4)=$P(XOPT,U,2),RET(5)=0 ;IHS/OIT/HMW SAC Exemption Applied For + I $$INHIBIT() Q + Q + ; +SET1(FLAG) ;Setup parameters + D GETENV^%ZOSV S U="^",XUENV=Y,XUCI=$P(Y,U,1),XQVOL=$P(Y,U,2),XUEON=^%ZOSF("EON"),XUEOFF=^("EOFF") + S X=$O(^XTV(8989.3,1,4,"B",XQVOL,0)),XUVOL=$S(X>0:^XTV(8989.3,1,4,X,0),1:XQVOL_"^y^1") S:$P(XUVOL,U,6)="y" XRTL=XUCI_","_XQVOL + S XOPT=$S($D(^XTV(8989.3,1,"XUS")):^("XUS"),1:"") F I=2:1:15 I $P(XOPT,U,I)="" S $P(XOPT,U,I)=$P("^5^900^1^1^^^^1^300^^^^N^90",U,I) + Q + ; +INHIBIT() ;Is Logon to this system Inhibited? + I $G(^%ZIS(14.5,"LOGON",XQVOL)) Q 1 + I $D(^%ZOSF("ACTJ")) X ^("ACTJ") I $P(XUVOL,U,3),($P(XUVOL,U,3)'>Y) Q 2 + Q 0 + ; +NOW S U="^",XUNOW=$$NOW^XLFDT(),DT=$P(XUNOW,"."),XUDEV=0 + Q + ; +STATE(%) ;Return a state value + ;XWBSTATE is required by XUSRB + Q:'$L($G(%)) $G(XWBSTATE) + Q $G(XWBSTATE(%)) + ; + ; +SET(%,VALUE) ;Set the state variable + I $G(%)="" S XWBSTATE=VALUE + S XWBSTATE(%)=VALUE + Q +KILL(%) ;Kill state variable + I $L($G(%)) K XWBSTATE(%) + Q + ; + ; +ADDCTXT(XQUSR,XCONTEXT) ; SUPPORTS DIRECT MODE IN BMX + N XQMES,XQRPC,X,Y,Z,%,XQOPT,TMP + S TMP=$NA(^TMP("XQCS",$J)) + S XQOPT=$O(^DIC(19,"B",XCONTEXT,0)) I 'XQOPT Q + S XQRPC=$O(^DIC(19,XQOPT,"RPC","B",0)) I 'XQRPC Q + I $D(@TMP@(XQRPC)) Q ; ITS ALREADY IN THERE ; NOTHING MORE TO DO + S XQMES=1 + D USER^XQCS I 'XQMES Q ; USER DOES NOT POSSES THIS APP CONTEXT + S XQRPC=0 + F S XQRPC=$O(^DIC(19,XQOPT,"RPC","B",XQRPC)) Q:'XQRPC S @TMP@(XQRPC,0)=XQRPC + Q + ; Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXNTEG.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXNTEG.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXNTEG.m (revision 1147) @@ -0,0 +1,80 @@ +BMXNTEG ;INTEGRITY CHECKER;JUN 28, 2010 + ;;4.1000;BMX;;Apr 17, 2011 + ; +START ; + NEW BYTE,COUNT,RTN + K ^UTILITY($J) + F I=1:1 S X=$T(LIST+I) Q:X="" S X=$P(X,";;",2),R=$P(X,"^",1),B=$P(X,"^",2),C=$P(X,"^",3),^UTILITY($J,R)=B_"^"_C + F I=1:1:6 S X=$P($T(@("LINE"_I)),";;",2,99),@("XBSUMBLD("_I_")=X") + X XBSUMBLD(1) + Q + ; +LINE1 ;;X XBSUMBLD(2),XBSUMBLD(6) +LINE2 ;;S RTN=0 F S RTN=$O(^UTILITY($J,RTN)) Q:RTN="" W !,RTN ZL @RTN S (BYTE,COUNT)=0 S X=$T(+1),X=$P(X," [ ",1) X XBSUMBLD(4),XBSUMBLD(3),XBSUMBLD(5) +LINE3 ;;F I=2:1 S X=$T(+I) Q:X="" X XBSUMBLD(4) +LINE4 ;;F J=1:1 S Y=$E(X,J) Q:Y="" S BYTE=BYTE+1,COUNT=COUNT+$A(Y) +LINE5 ;;S B=$P(^UTILITY($J,RTN),"^",1),C=$P(^(RTN),"^",2) I B'=BYTE!(C'=COUNT) W " has been modified" +LINE6 ;;K XBSUMBLD,B,C,I,J,R,X,Y + ; +LIST ; + ;;BMXADE1^3028^202895 + ;;BMXADE2^3250^215402 + ;;BMXADO^6549^418183 + ;;BMXADO2^3489^255576 + ;;BMXADOF^11452^725170 + ;;BMXADOF1^3281^207254 + ;;BMXADOF2^2138^139526 + ;;BMXADOFD^2927^184329 + ;;BMXADOFS^6736^406496 + ;;BMXADOI^2215^134635 + ;;BMXADOS^9227^581516 + ;;BMXADOS1^2790^177677 + ;;BMXADOV^5739^373853 + ;;BMXADOV1^9072^554917 + ;;BMXADOV2^4690^289928 + ;;BMXADOVJ^3534^225846 + ;;BMXADOX^13904^870307 + ;;BMXADOX1^11753^751140 + ;;BMXADOX2^3126^199436 + ;;BMXADOXX^12226^762829 + ;;BMXADOXY^11992^769541 + ;;BMXE01^2610^185734 + ;;BMXEHR^7337^475235 + ;;BMXFIND^7919^563026 + ;;BMXG^1970^120497 + ;;BMXGETS^4309^308756 + ;;BMXMBRK^6045^399724 + ;;BMXMBRK2^3621^233173 + ;;BMXMEVN^7145^502429 + ;;BMXMON^10184^719138 + ;;BMXMSEC^3155^217778 + ;;BMXNTEG^1953^121515 + ;;BMXPO^1522^102017 + ;;BMXPRS^2153^134459 + ;;BMXRPC^5755^428908 + ;;BMXRPC1^7622^559228 + ;;BMXRPC10^9682^623943 + ;;BMXRPC2^3531^243905 + ;;BMXRPC3^6387^443331 + ;;BMXRPC4^4941^310665 + ;;BMXRPC5^3896^288956 + ;;BMXRPC6^3759^270824 + ;;BMXRPC7^5776^411297 + ;;BMXRPC8^2240^165807 + ;;BMXRPC9^7123^467733 + ;;BMXSQL^10871^727603 + ;;BMXSQL1^9912^615416 + ;;BMXSQL2^2748^183784 + ;;BMXSQL3^13511^868130 + ;;BMXSQL4^1313^88507 + ;;BMXSQL5^6648^433320 + ;;BMXSQL6^10606^683092 + ;;BMXSQL7^8098^527973 + ;;BMXSQL91^4332^281563 + ;;BMXTABLE^159^9991 + ;;BMXTRS^1300^81294 + ;;BMXUTL1^7818^520399 + ;;BMXUTL2^900^60487 + ;;BMXUTL5^5330^358896 + ;;BMXUTL6^1141^75004 + ;;BMXUTL7^766^54422 Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXPO.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXPO.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXPO.m (revision 1147) @@ -0,0 +1,71 @@ +BMXPO ; IHS/CMI/MAW - Populate appcontext with all namespaced RPC's ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; +MAIN ;EP - this is the main routine driver + N BMXQFLG + D ASK + I $G(BMXQFLG) D XIT Q + ;D CLEAN(BMXAPP) + D POP(BMXAPP,BMXNS) + D XIT + Q + ; +GUIEP(RETVAL,BMXSTR) ;EP - gui entry point + N P,BMXAPP,BMXNS + S P="|" + S BMXGUI=1 + S BMXAPP=$P(BMXSTR,P) + S BMXNS=$P(BMXSTR,P,2) + K ^BMXTMP($J) + S RETVAL="^BMXTMP("_$J_")" + S ^BMXTMP($J,0)="T00250DATA"_$C(30) + ;D CLEAN(BMXAPP) + D POP(BMXAPP,BMXNS) + D XIT + Q + ; +ASK ;-- ask the name of the OPTION to populate + W ! + S DIC=19,DIC(0)="AEMQZ",DIC("A")="Populate which Application Context: " + D ^DIC + I '$G(Y) S BMXQFLG=1 Q + S BMXAPP=+Y + W ! + K DIC + S DIR(0)="F^1:3",DIR("A")="Populate RPC's from which Namespace: " + D ^DIR + I $D(DIRUT) S BMXQFLG=1 Q + S BMXNS=$G(Y) + Q + ; +CLEAN(APP) ;-- clean out the RPC multiple first + S DA(1)=APP + S DIK="^DIC(19,"_DA(1)_","_"""RPC"""_"," + N BMXDA + S BMXDA=0 F S BDMDA=$O(^DIC(19,APP,"RPC",BMXDA)) Q:'BMXDA D + . S DA=BMXDA + . D ^DIK + K ^DIC(19,APP,"RPC","B") + Q + ; +POP(APP,NS) ;populate the app context with RPC's + I '$G(BMXGUI) W !,"Populating Application Context" + N BMXDA + S BMXDA=NS + F S BMXDA=$O(^XWB(8994,"B",BMXDA)) Q:BMXDA=""!($E(BMXDA,1,3)'=NS) D + . N BMXIEN + . S BMXIEN=0 F S BMXIEN=$O(^XWB(8994,"B",BMXDA,BMXIEN)) Q:'BMXIEN D + .. Q:$O(^DIC(19,APP,"RPC","B",BMXIEN,0)) + .. N BDMIENS,BDMFDA,BDMERR + .. S BDMIENS(1)=APP + .. S BDMIENS="+2,"_APP_"," + .. S BDMFDA(19.05,BDMIENS,.01)=BMXIEN + .. D UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)") + .. I '$G(BMXGUI) W "." + Q + ; +XIT ;-- clean vars + D EN^XBVK("BMX") + Q + ; Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXPRS.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXPRS.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXPRS.m (revision 1147) @@ -0,0 +1,104 @@ +BMXPRS ; IHS/OIT/HMW - BMX WINDOWS UTILS ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; +PARSE(X) ;EP-Parse SQL Statement into array + ;Input SQL statement as X + ;Returns BMXTK() array + ;Errors returned in BMXERR + ; + D PRE + Q:$D(BMXERR) + D POST + Q + ; +POST2 ;EP - Remove commas from BMXTK + N J,K + S J=0 F S J=$O(BMXTK(J)) Q:'+J D + . S K=$O(BMXTK(J)) + . I +K,","=$G(BMXTK(K)) D + . . K BMXTK(K) + . . D PACK(J) + . . Q + . Q + Q + ; +POST ; + ;Combine multi-character operators + N J + S J=0 F S J=$O(BMXTK(J)) Q:'+J D + . I ">"=BMXTK(J) D Q + . . I "="[$G(BMXTK(J+1)) D Q + . . . S BMXTK(J)=BMXTK(J)_"=" + . . . K BMXTK(J+1) + . . . D PACK(J) + . . I "<"[$G(BMXTK(J+1)) D Q + . . . S BMXTK(J)="<"_BMXTK(J) + . . . K BMXTK(J+1) + . . . D PACK(J) + . I "<"=BMXTK(J) D Q + . . I "=>"[$G(BMXTK(J+1)) D + . . . S BMXTK(J)=BMXTK(J)_BMXTK(J+1) + . . . K BMXTK(J+1) + . . . D PACK(J) + . I "="=BMXTK(J) D Q + . . I "<>"[$G(BMXTK(J+1)) D + . . . S BMXTK(J)=BMXTK(J+1)_BMXTK(J) + . . . K BMXTK(J+1) + . . . D PACK(J) + Q + ; +PACK(J) ; + F S J=$O(BMXTK(J)) Q:'+J D + . S BMXTK(J-1)=BMXTK(J) + . K BMXTK(J) + Q + ; +PRE N P,T,Q,Q1,A,B S (P,T,Q)=0,BMXTK="",A=0 +START S A=A+1 + S B=$E(X,A) + I B="" G B5 + I 'Q G QUOTE + I B=$C(39) G QUOTE + S BMXTK=BMXTK_B G START +QUOTE I B'=$C(39) G SPACE + I Q G QUOTE2 + ;S Q=1,BMXTK=B G START + S Q=1,BMXTK=BMXTK_B G START +QUOTE2 S Q1=B,A=A+1,B=$E(X,A) + I B']"" G QUOTE3 + I B'=$C(39) G QUOTE3 + S BMXTK=BMXTK_Q1_B G START +QUOTE3 S A=A-1,B=Q1,BMXTK=BMXTK_B,Q=0 G START +SPACE I B'=" " G OP + I BMXTK]"" S T=T+1,BMXTK(T)=BMXTK,BMXTK="" + G START +OP I "=><"'[B G OPAREN + I BMXTK]"" S T=T+1,BMXTK(T)=BMXTK,BMXTK="" + S T=T+1,BMXTK(T)=B,BMXTK="" + G START +OPAREN I B'="(" G CPAREN + S P=P+1 + I BMXTK]"" S T=T+1,BMXTK(T)=BMXTK,BMXTK="" + S T=T+1,BMXTK(T)=B G START +CPAREN I B'=")" G B2 + I P G B1 + G B0 + ; +B0 S BMXERR="SQL SYNTAX ERROR" D ERROR G B5 +B1 S P=P-1 + I BMXTK]"" S T=T+1,BMXTK(T)=BMXTK,BMXTK="" + S T=T+1,BMXTK(T)=B G START +B2 I B'="," G B3 + S T=T+1,BMXTK(T)=BMXTK,T=T+1,BMXTK(T)=",",BMXTK="" G START +B3 S BMXTK=BMXTK_B +B4 G START +B5 I BMXTK]"" S T=T+1,BMXTK(T)=BMXTK + I $D(BMXERR) G B6 + I P S BMXERR="SQL SYNTAX ERROR: MATCHING PARENTHESIS NOT FOUND" D ERROR + E I Q S BMXERR="SQL SYNTAX ERROR: MATCHING QUOTE NOT FOUND" D ERROR + I P>0 G START +B6 Q + ; +ERROR ;W !,"ERROR=",BMXERR,! Q + Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC.m (revision 1147) @@ -0,0 +1,178 @@ +BMXRPC ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ; 4/7/11 2:06pm + ;;4.1000;BMX;;Apr 17, 2011 + ;;Stolen from:* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER * + ;; GENERIC LOOKUP UTILITY FOR RETURNING MATCHING RECORDS + ;; OR TABLES TO RPC'S. + ; + ; *** NOTE: I have discovered a number of cases where these calls + ; produce errors (with error messages to IO) or simply + ; do not work correctly. ANY CALL to this utility + ; should be thoroughly tested in the M environment + ; before being used as an RPC. + ; + ; Change Log: + ; WV/SMH on Apr 7 2011 -- added RPC for determining UTF-8 support on GT.M + ; Tag: UTF-8 + ; + ;---------- +LOOKUP(BMXGBL,BMXFL,BMXFLDS,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,BMXMC) ;EP + ;---> Places matching records from requested file into a + ;---> result global, ^BMXTEMP($J). The exact global name + ;---> is returned in the first parameter (BMXGBL). + ;---> Records are returned one per node in the result global. + ;---> Each record is terminated with a $C(30), for parsing out + ;---> on the VB side, since the Broker concatenates all nodes + ;---> into a single string when passing the data out of M. + ;---> Requested fields within records are delimited by "^". + ;---> NOTE: The first "^"-piece of every node is the IEN of + ;---> that entry in its file; the requested fields follow. + ;---> The final record (node) contains Error Delimiter, + ; $C(31)_$C(31), followed by error text, if any. + ; + ;---> Parameters: + ; 1 - BMXGBL (ret) Name of result global for Broker. + ; 2 - BMXFL (req) File for lookup. + ; 3 - BMXFLDS (opt) Fields to return w/each entry. + ; 4 - BMXFLG (opt) Flags in DIC(0); If null, "M" is sent. + ; 5 - BMXIN (opt) Input to match on (see Algorithm below). + ; 6 - BMXMX (opt) Maximum number of entries to return. + ; 7 - BMXIX (opt) Indexes to search. + ; 8 - BMXSCR (opt) Screen/filter (M code). + ; 9 - BMXMC (opt) Mixed Case: 1=mixed case, 0=no change. + ; (Converts data in uppercase to mixed case.) + ; + ;---> Set variables, kill temp globals. + N (BMXGBL,BMXFL,BMXFLDS,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,BMXMC) ;IHS/OIT/HMW SAC Exemption Applied For + S BMX31=$C(31)_$C(31) + S BMXGBL="^BMXTEMP("_$J_")",BMXERR="",U="^" + K ^BMXTMP($J),^BMXTEMP($J) + ; + ;---> If file number not provided, return error. + I '$G(BMXFL) D ERROUT("File number not provided.",1) Q + ; + ;---> If no fields provided, pass .01. + ;---> IEN will always be the first piece of data returned. + ;---> NOTE: If .01 is NOT included, but the Index to lookup on is + ;---> NOT on the .01, then the .01 will be returned + ;---> automatically as the second ^-piece of data in the + ;---> Result Global. + ;---> So it would be: IEN^.01^requested fields... + I $G(BMXFLDS)="" S BMXFLDS=".01" + ; + ;---> If no index or flag provided, set flag="M". + I $G(BMXFLG)="" D + .I $G(BMXIX)="" S BMXFLG="M" Q + .S BMXFLG="" + ; + ;---> If no Maximum Number provided, set it to 200. + I '$G(BMXMX) S BMXMX=200 + ; + ;---> Define index and screen. + S:'$D(BMXIX) BMXIX="" + S:'$D(BMXSCR) BMXSCR="" + ; + ;---> Set Target Global for output and errors. + S BMXG="^BMXTMP($J)" + ; + ;---> If Mixed Case not set, set to No Change. + I '$D(BMXMC) S BMXMC=0 + ; + ;---> Silent Fileman call. + D + .I $G(BMXIN)="" D Q + ..D LIST^DIC(BMXFL,,BMXFLDS,,BMXMX,0,,BMXIX,BMXSCR,,BMXG,BMXG) + .D FIND^DIC(BMXFL,,BMXFLDS,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,,BMXG,BMXG) + ; + D WRITE + Q + ; + ; + ;---------- +WRITE ;EP + ;---> Collect data for matching records and write in result global. + ; + ;---> First, check for errors. + ;---> If errors exist, write them and quit. + N I,N,X + I $D(^BMXTMP($J,"DIERR")) I $O(^("DIERR",0)) D Q + .S N=0,X="" + .F S N=$O(^BMXTMP($J,"DIERR",N)) Q:'N D + ..N M S M=0 + ..F S M=$O(^BMXTMP($J,"DIERR",N,"TEXT",M)) Q:'M D + ...S X=X_^BMXTMP($J,"DIERR",N,"TEXT",M)_" " + .D ERROUT(X,1) + ; + ; + ;---> Write Field Names + S $P(ASDX,"^",1)="IEN" + F ASDC=1:1:$L(BMXFLDS,";") D + . S ASDXFNUM=$P(BMXFLDS,";",ASDC) + . S ASDXFNAM=$P(^DD(BMXFL,ASDXFNUM,0),"^") + . S:ASDXFNAM="" ASDXFNAM="UNKNOWN"_ASDC + . S $P(ASDX,"^",ASDC+1)=ASDXFNAM + S ^BMXTEMP($J,1)=ASDX_$C(30) + ;---> Write valid results. + ;---> Loop through the IEN node (...2,N) of the temp global. + N I,N,X S N=0 + F I=2:1 S N=$O(^BMXTMP($J,"DILIST",2,N)) Q:'N D + .;---> Always set first piece of X=IEN of entry. + .S X=^BMXTMP($J,"DILIST",2,N) + .; + .;---> Collect other fields and concatenate to X. + .N M S M=0 + .F S M=$O(^BMXTMP($J,"DILIST","ID",N,M)) Q:'M D + ..S X=X_U_^BMXTMP($J,"DILIST","ID",N,M) + .; + .;---> Convert data to mixed case if BMXMC=1. + .S:BMXMC X=$$T^BMXTRS(X) + .; + .;---> Set data in result global. + .S ^BMXTEMP($J,I)=X_$C(30) + ; + ;---> If no results, report it as an error. + D:'$O(^BMXTEMP($J,0)) + .I BMXIN]"" S BMXERR="No entry matches """_BMXIN_"""." Q + .S BMXERR="Either the lookup file is empty" + .S BMXERR=BMXERR_" or all entries are screened (software error)." + ; + ;---> Tack on Error Delimiter and any error. + S ^BMXTEMP($J,I)=BMX31_BMXERR + Q + ; + ; + ;---------- +ERROUT(BMXERR,I) ;EP + ;---> Save next line for Error Code File if ever used. + ;---> If necessary, use I>1 to avoid overwriting valid data. + S:'$G(I) I=1 + S ^BMXTEMP($J,I)=BMX31_BMXERR + Q + ; + ; +PASSERR(BMXGBL,BMXERR) ;EP + ;---> If the RPC routine calling the BMX Generic Lookup above + ;---> detects a specific error prior to the call and wants to pass + ;---> that error in the result global rather than a generic error, + ;---> then a call to this function (PASSERR) can be made. + ;---> This call will store the error text passed in the result global. + ;---> The calling routine should then quit (abort its call to the + ;---> BMX Generic Lookup function above). + ; + ;---> Parameters: + ; 1 - BMXGBL (ret) Name of result global for Broker. + ; 2 - BMXERR (req) Text of error to be stored in result global. + ; + S:$G(BMXERR)="" BMXERR="Error not passed (software error)." + ; + N BMX31 S BMX31=$C(31)_$C(31) + K ^BMXTMP($J),^BMXTEMP($J) + S BMXGBL="^BMXTEMP("_$J_")" + S ^BMXTEMP($J,1)=BMX31_BMXERR + Q +UTF8(BMXRET) ; PEP - Does this DB Support UTF-8 encoding? + ; RPC: BMX UTF-8 + ; 0 for FALSE for 1 for TRUE. + I ^%ZOSF("OS")'["GT.M" S BMXRET=0 QUIT + I $ZCHSET="M" S BMXRET=0 QUIT + I $ZCHSET="UTF-8" S BMXRET=1 QUIT + S BMXRET=0 QUIT ;default Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC1.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC1.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC1.m (revision 1147) @@ -0,0 +1,238 @@ +BMXRPC1 ; IHS/OIT/HMW - UTIL: REMOTE PROCEDURE CALLS ; + ;;4.1000;BMX;;Apr 17, 2011 + ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER * + ;; UTILITY: CODE FOR REMOTE PROCEDURE CALLS. + ;; RETURNS PATIENT DATA, HEALTH SUMMARY, FACE SHEET. + ; + ; + ;---------- +PDATA(BMXDATA,BMXDFN) ;EP + ;---> Return Patient Data in 5 ^-delimited pieces: + ;---> 1 - DOB in format: OCT 01,1994. + ;---> 2 - Age in format: 35 Months. + ;---> 3 - Text of Patient's sex. + ;---> 4 - HRCN in the format XX-XX-XX. + ;---> 5 - Text of ACTIVE/INACTIVE Status. + ;---> Parameters: + ; 1 - BMXDATA (ret) String of patient data||error. + ; 2 - BMXDFN (req) DFN of patient. + ; + ;---> Delimiter to pass error with result to GUI. + N BMX31,BMXERR S BMX31=$C(31)_$C(31) + S BMXDATA="",BMXERR="" + ; + ;---> If DFN not supplied, set Error Code and quit. + I '$G(BMXDFN) D Q + .;D ERRCD^BMXUTL2(201,.BMXERR) S BMXDATA=BMX31_BMXERR + ; + ;---> DOB. + S BMXDATA=$$TXDT1^BMXUTL5($$DOB^BMXUTL1(BMXDFN)) + ; + ;---> Age. + S BMXDATA=BMXDATA_U_$$AGEF^BMXUTL1(BMXDFN) + ; + ;---> Text of sex. + S BMXDATA=BMXDATA_U_$$SEXW^BMXUTL1(BMXDFN) + ; + ;---> HRCN, format XX-XX-XX. + S BMXDATA=BMXDATA_U_$$HRCN^BMXUTL1(BMXDFN) + ; + ;---> Active/Inactive Status. + ;S BMXDATA=BMXDATA_U_$$ACTIVE^BMXUTL1(BMXDFN) + ; + S BMXDATA=BMXDATA_BMX31 + ; + Q + ; + ; + ;---------- +HS(BMXGBL,BMXDFN) ;EP + ;---> Return patient's Health Summary in global array, ^BMXTEMP($J,"HS". + ;---> Lines delimited by "^". + ;---> Called by RPC: BMX IMMSERVE PT PROFILE + ;---> Parameters: + ; 1 - BMXGBL (ret) Name of result global containing patient's + ; Health Summary, passed to Broker. + ; 2 - BMXDFN (req) DFN of patient. + ; + ;---> Delimiter to pass error with result to GUI. + N BMX30,BMX31,BMXERR,X + S BMX30=$C(30),BMX31=$C(31)_$C(31) + S BMXGBL="^BMXTEMP("_$J_",""HS"")",BMXERR="" + K ^BMXTEMP($J,"HS") + ; + ;---> If DFN not supplied, set Error Code and quit. + I '$G(BMXDFN) D Q + .;D ERRCD^BMXUTL2(201,.BMXERR) S ^BMXTEMP($J,"HS",I)=BMX31_BMXERR + ; + ;---> If patient does not exist, set Error Code and quit. + I '$D(^AUPNPAT(BMXDFN,0)) D Q + .;D ERRCD^BMXUTL2(203,.BMXERR) S ^BMXTEMP($J,"HS",I)=BMX31_BMXERR + ; + N APCHSPAT,APCHSTYP + S APCHSPAT=BMXDFN,APCHSTYP=7 + ;---> Doesn't work from Device 56. + ;D GUIR^XBLM("EN^APCHS","^TMP(""BMXHS"",$J,") + ; + ;---> Generate a host file name. + N BMXFN S BMXFN="XB"_$J + ; + D + .;---> Important to preserve IO variables for when $I returns to 56. + .N IO,IOBS,IOF,IOHG,IOM,ION,IOPAR,IOS,IOSL,IOST,IOT,IOUPAR,IOXY + .; + .;---> Open host file to receive legacy code display. + .;S Y=$$OPEN^%ZISH($$HFSPATH^BMXUTL1,BMXFN,"W") + .; + .;---> Call to legacy code for Health Summary display. + .D EN^APCHS + .;---> Write End of File (EOF) marker. + .W $C(9) + .; + .;---> %ZISC doesn't close Device 51 when called from TCPIP socket? + .;D ^%ZISC + .;---> Buffer won't write out to file until the device is closed + .;---> or the buffer is flushed by some other command. + .;---> At this point, host file exists but has 0 bytes. + .;C 51 + .;---> Now host file contains legacy code display data. + .; + .;---> For some reason %ZISH cannot open the host file a second time. + .;S Y=$$OPEN^%ZISH($$HFSPATH^BMXUTL1,BMXFN,"R") + .;O 51:($$HFSPATH^BMXUTL1_BMXFN:"R") + .;U 51 + .; + .;---> Read in the host file. + .D + ..;---> Stop reading Host File if line contains EOF $C(9). + ..;N I,Y F I=1:1 R Y Q:Y[$C(9) S ^TMP("BMXHS",$J,I)=Y + .; + .;---> %ZISC doesn't close Device 51 when called from TCPIP socket? + .;D ^%ZISC + .;C 51 + ; + ;---> At this point $I=1. The job has "forgotten" its $I, even + ;---> though %SS shows 56 as the current device. $I=1 causes a + ;---> at CAPI+10^XWBBRK2. A simple USE 56 command + ;---> appears to "remind" the job its $I is 56, and it works. + ;---> Possibly this is something %ZISC ordinarily does. + ;U 56 + ; + ;---> Copy Health Summary to global array for passing back to GUI. + N I,N,U,X S U="^" + S N=0 + F I=1:1 S N=$O(^TMP("BMXHS",$J,N)) Q:'N D + .;---> Set null lines (line breaks) equal to one space, so that + .;---> Windows reader will quit only at the final "null" line. + .S X=^TMP("BMXHS",$J,N) S:X="" X=" " + .S ^BMXTEMP($J,"HS",I)=X_BMX30 + ; + ;---> If no Health Summary produced, report it as an error. + D:'$O(^BMXTEMP($J,"HS",0)) + .;D ERRCD^BMXUTL2(407,.BMXERR) S ^BMXTEMP($J,"HS",I)=BMX31_BMXERR + ; + ;---> Tack on Error Delimiter and any error. + S ^BMXTEMP($J,"HS",I)=BMX31_BMXERR + ; + ;---> This works; host file gets deleted. + ;S Y=$$DEL^%ZISH($$HFSPATH^BMXUTL1,BMXFN) + K ^TMP("BMXHS",$J) + Q + ; + ; + ;---------- +FACE(BMXGBL,BMXDFN) ;EP + ;---> Return patient's Face Sheet in global array, ^BMXTEMP($J,"FACE". + ;---> Lines delimited by "^". + ;---> Called by RPC: BMX IMMSERVE PT PROFILE + ;---> Parameters: + ; 1 - BMXGBL (ret) Name of result global containing patient's + ; Face Sheet, passed to Broker. + ; 2 - BMXDFN (req) DFN of patient. + ; + ;---> Delimiter to pass error with result to GUI. + N BMX30,BMX31,BMXERR,X + S BMX30=$C(30),BMX31=$C(31)_$C(31) + S BMXGBL="^BMXTEMP("_$J_",""FACE"")",BMXERR="" + K ^BMXTEMP($J,"FACE") + ; + ;---> If DFN not supplied, set Error Code and quit. + I '$G(BMXDFN) D Q + .;D ERRCD^BMXUTL2(201,.BMXERR) S ^BMXTEMP($J,"FACE",I)=BMX31_BMXERR + ; + ;---> If patient does not exist, set Error Code and quit. + I '$D(^AUPNPAT(BMXDFN,0)) D Q + .;D ERRCD^BMXUTL2(203,.BMXERR) S ^BMXTEMP($J,"FACE",I)=BMX31_BMXERR + ; + N DFN S DFN=BMXDFN + ;---> Doesn't work from Device 56. + ;---> Generate a host file name. + N BMXFN S BMXFN="XB"_$J + ; + D + .;---> Important to preserve IO variables for when $I returns to 56. + .N IO,IOBS,IOF,IOHG,IOM,ION,IOPAR,IOS,IOSL,IOST,IOT,IOUPAR,IOXY + .; + .;---> Open host file to receive legacy code display. + .;S Y=$$OPEN^%ZISH($$HFSPATH^BMXUTL1,BMXFN,"W") + .; + .;---> Call to legacy code for Face Sheet display. + .U 51 + .;D ^BMXFACE + .;---> Write End of File (EOF) marker. + .W $C(9) + .; + .;---> %ZISC doesn't close Device 51 when called from TCPIP socket? + .;D ^%ZISC + .;---> Buffer won't write out to file until the device is closed + .;---> or the buffer is flushed by some other command. + .;---> At this point, host file exists but has 0 bytes. + .;C 51 + .;---> Now host file contains legacy code display data. + .; + .;---> For some reason %ZISH cannot open the host file a second time. + .;S Y=$$OPEN^%ZISH($$HFSPATH^BMXUTL1,BMXFN,"R") + .;O 51:($$HFSPATH^BMXUTL1_BMXFN:"R") + .U 51 + .; + .;---> Read in the host file. + .D + ..;---> Need some way to mark the end of legacy code output. + ..;---> Stop reading Host File if line contains EOF $C(9). + ..;---> (I added $C(9) above, after ^BMXFACE completed.) + ..;N I,Y F I=1:1 R Y Q:Y[$C(9) S ^TMP("BMXFACE",$J,I)=Y + .; + .;---> %ZISC doesn't close Device 51 when called from TCPIP socket? + .;D ^%ZISC + .;C 51 + ; + ;---> At this point $I=1. The job has "forgotten" its $I, even + ;---> though %SS shows 56 as the current device. $I=1 causes a + ;---> at CAPI+10^XWBBRK2. A simple USE 56 command + ;---> appears to "remind" the job its $I is 56, and it works. + ;---> Possibly this is something %ZISC ordinarily does. + U 56 + ; + ;---> Copy Face Sheet to global array for passing back to GUI. + N I,N,U,X S U="^" + S N=0 + F I=1:1 S N=$O(^TMP("BMXFACE",$J,N)) Q:'N D + .;---> Set null lines (line breaks) equal to one space, so that + .;---> Windows reader will quit only at the final "null" line. + .S X=^TMP("BMXFACE",$J,N) S:X="" X=" " + .;---> Remove Carriage Return (13)_Formfeed (12) characters. + .I X[$C(13)_$C(12) S X=$P(X,$C(13)_$C(12),2) + .; + .S ^BMXTEMP($J,"FACE",I)=X_BMX30 + ; + ;---> If no Health Summary produced, report it as an error. + D:'$O(^BMXTEMP($J,"FACE",0)) + .;D ERRCD^BMXUTL2(408,.BMXERR) S ^BMXTEMP($J,"FACE",I)=BMX31_BMXERR + ; + ;---> Tack on Error Delimiter and any error. + S ^BMXTEMP($J,"FACE",I)=BMX31_BMXERR + ; + ;---> This works; host file gets deleted. + ;S Y=$$DEL^%ZISH($$HFSPATH^BMXUTL1,BMXFN) + K ^TMP("BMXFACE",$J) + Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC10.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC10.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC10.m (revision 1147) @@ -0,0 +1,284 @@ +BMXRPC10 ; IHS/OIT/GIS - RPC CALL FOR EXTENDED BROKER FUNCTIONALITY ; 08 Jun 2010 8:47 AM + ;;4.1000;BMX;;Apr 17, 2011 + ;; 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 VDT20 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 + 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 + I '$G(DUZ(2)) Q ; DIVISION + S BMXCNTR=0 + S BMXDA=0 F S BMXDA=$O(PIEN(BMXDA)) Q:'BMXDA D + . 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 + ; Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC2.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC2.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC2.m (revision 1147) @@ -0,0 +1,112 @@ +BMXRPC2 ; IHS/OIT/HMW - FIELD LIST ; + ;;4.1000;BMX;;Apr 17, 2011 + ; +FLDLIST(BMXGBL,BMXFL,BMXATTR,BMXSCR) ;EP + ;TODO: Change all this to be a hard-coded $O thru ^DD + ;Returns info in BMXATTR for all fields in file number BMXFL + ;BMXSCR is executable code to set $T + ; When BMXSCR is executed, the field number is in BMXFLD + ;See FileMan documentation for FIELD^DD for description + ;of Attributes + ; + ;---> Set variables, kill temp globals. + ;S ^HW("F",BMXFL)="" + ;S ^HW("F",BMXATTR)="" + N BMX31,BMXERR,BMXG,BMXFLD,BMX,BMXC,BMXT + S BMX31=$C(31)_$C(31) + S BMXGBL="BMXTMP("_$J_")",BMXERR="",U="^" + K BMXTMP($J) + ; + ;---> If file number not provided, return error. + ;I '+BMXFL D ERROUT^BMXRPC("File number not provided.",1) Q + ;---> If file number not provided check for file name. + I +BMXFL'=BMXFL D + . S BMXFL=$TR(BMXFL,"_"," ") + . I '$D(^DIC("B",BMXFL)) S BMXFL="" Q + . S BMXFL=$O(^DIC("B",BMXFL,0)) + I '$G(BMXFL) D ERROUT^BMXRPC("File number not provided.",1) Q + ; + ;---> If no such file, return error. + I '$D(^DD(BMXFL,0)) D ERROUT^BMXRPC("File does not exist.",1) Q + ; + ;---> Validate screen code + I $G(BMXSCR)="" S BMXSCR="I 1" + S X=$G(BMXSCR) + I X]"" D ^DIM + I '$D(X) S BMXSCR="I 1" ;Default to no screen + ; + ;---> Set Target Global for output and errors. + S BMXG="BMXTMP($J,""DID"")" + ; + ;---> Loop through ^DD(FileNumber,FieldNumber,0) to get field names + K BMXTMP($J) + I $G(BMXATTR)="" S BMXATTR="LABEL" ;Changed from NAME to LABEL + ;---> Attribute Names + F I=1:1:$L(BMXATTR,";") S BMXT($P(BMXATTR,";",I))="" + S (BMX,BMXC)=0 F S BMX=$O(BMXT(BMX)) Q:BMX="" D + . S BMXC=BMXC+1 + . S $P(BMXT,U,BMXC)="T00030"_BMX + S BMXTMP($J,1)="T00030NUMBER"_U_BMXT_$C(30) + ; + ;S BMXFLD=0 F I=2:1 S BMXFLD=$O(^DD(BMXFL,BMXFLD)) Q:'+BMXFLD D + S BMXTMP($J,2)=".001^BMXIEN"_$C(30) + S BMXFLDN=0 F I=3:1 S BMXFLDN=$O(^DD(BMXFL,"B",BMXFLDN)) Q:BMXFLDN="" D + . S BMXFLD=$O(^DD(BMXFL,"B",BMXFLDN,0)) Q:'+BMXFLD + . X BMXSCR Q:'$T + . D FIELD^DID(BMXFL,BMXFLD,,BMXATTR,BMXG,BMXG) + . K BMXT S (BMXC,BMX)=0 + . F S BMX=$O(BMXTMP($J,"DID",BMX)) Q:BMX="" D + . . S BMXC=BMXC+1 + . . S $P(BMXT,U,BMXC)=BMXTMP($J,"DID",BMX) + . S BMXTMP($J,I)=BMXFLD_U_$TR(BMXT," ","_")_$C(30) + ;S I=I+1,BMXTMP($J,I)=".001^BMXIEN"_$C(30) + S I=I+1 + K BMXTMP($J,"DID") + ;---> Tack on Error Delimiter and any error. + S BMXTMP($J,I)=BMX31_BMXERR + Q + ; +MLTLIST(BMXGBL,BMXFL,BMXONEOK) ;EP + ;Returns list of multiple fields in file BMXFL, returns only one field + ;if BMXONEOK is TRUE + ;S ^HW($H,"MLTLIST","FL")=BMXFL + ;S ^HW($H,"MLTLIST","ONE")=BMXONEOK + N BMX31,BMXERR,BMXG,BMXFLD,BMX,BMXC,BMXT,I + S BMX31=$C(31)_$C(31) + S BMXGBL="BMXTMP("_$J_")",BMXERR="",U="^" + K BMXTMP($J) + ; + ;---> If file number not provided check for file name. + I +BMXFL'=BMXFL D + . S BMXFL=$TR(BMXFL,"_"," ") + . I '$D(^DIC("B",BMXFL)) S BMXFL="" Q + . S BMXFL=$O(^DIC("B",BMXFL,0)) + I '$G(BMXFL) D ERROUT^BMXRPC("File number not provided.",1) Q + ; + ;---> If no such file, return error. + I '$D(^DD(BMXFL,0)) D ERROUT^BMXRPC("File does not exist.",1) Q + ; + ;---> Column Headers + S BMXTMP($J,1)="T00030NUMBER"_U_"T00030NAME"_$C(30) + ; + ;---> $O thru ^DD(BMXFL,"SB" to get subfile numbers and names + S I=2 + N BMXSB,BMXSBN,BMXSBF,BMXFOUND + S BMXFOUND=0 + I $D(^DD(BMXFL,"SB")) D + . S BMXSB=0 + . F S BMXSB=$O(^DD(BMXFL,"SB",BMXSB)) Q:'+BMXSB D I BMXFOUND Q:BMXONEOK=1 + . . S BMXSBF=$O(^DD(BMXFL,"SB",BMXSB,0)) + . . Q:'+BMXSBF + . . S BMXSBN=$G(^DD(BMXFL,BMXSBF,0)) + . . Q:BMXSBN="" + . . S BMXZ=$G(^DD(BMXSB,.01,0)) + . . Q:$P(BMXZ,U,2)["W" + . . S BMXFOUND=1 + . . S BMXSBN=$P(BMXSBN,U) + . . S BMXTMP($J,I)=BMXSB_U_BMXSBN_$C(30) + . . S I=I+1 + ; + ;---> Tack on Error Delimiter and any error. + S BMXTMP($J,I)=BMX31_BMXERR + Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC3.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC3.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC3.m (revision 1147) @@ -0,0 +1,237 @@ +BMXRPC3 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ; 4/6/11 4:56pm + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; Changed for .1000 by WV/SMH on April 6 2011 + ; - References to ^AUTTSITE in GETFC & GETFCRS removed, as VISTA doesn't use this file + ; - + ; + ; + ; +VARVAL(RESULT,VARIABLE) ;returns value of passed in variable + S VARIABLE=$TR(VARIABLE,"~","^") + S RESULT=VARIABLE ;can do this with the REFERENCE type parameter + Q + ;See GETV^XWBBRK for how we get the REFERENCE type parameter + ; +USER(RESULT,D) ; + ; + I '+D S RESULT="" Q + S RESULT=$P($G(^VA(200,D,0)),"^") + Q + ; +NTUSER(BMXY,BMXNTUSE) ;EP + ;Old code. Retain for reference + ;Returns NTDomain^NTUserName^RPMSName for user having DUZ=D + ;TODO: Move ANMC NT USERS file + ;from AZZWNT to BMX namespace and numberspace + ; + ;N BMX,BMXNOD,BMXDOM,BMXNAM,BMXCOL,BMXRNAM + ;S (BMXDOM,BMXNAM,BMXRNAM)="" + ;S U="^" + ;I '+D S RESULT="" Q + ;S BMXRNAM=$G(^VA(200,D,0)),BMXRNAM=$P(BMXRNAM,U) + ;I '$D(^AZZWNT("DUZ",D)) D NTU1 Q + ;S BMX=$O(^AZZWNT("DUZ",D,0)) + ;I '+BMX D NTU1 Q + ;I '$D(^AZZWNT(BMX,0)) D NTU1 Q + ;S BMXNOD=^AZZWNT(BMX,0) + ;S BMXDOM=$P(BMXNOD,U,2) + ;S BMXNAM=$P(BMXNOD,U) ;,4) + ;D NTU1 + Q + ; + ; +NTUGETD(BMXY,BMXNTNAM) ;EP + ;Entry point for debugging + ; + ;D DEBUG^%Serenji("NTUGETD^BMXRPC3(.BMXY,BMXNTNAM)") + Q + ; +NTUGET(BMXY,BMXNTNAM) ;EP + ; + ;Returns A ENCRYPTED and V ENCRYPTED for NT User BMXNTNM + ;Called by RPC BMXNetGetCodes + N BMXI,BMXNTID,BMXNTID,BMXNOD,BMXA,BMXV + S BMXI=0 + S BMXY="^BMXTMP("_$J_")" + S X="NTUET^BMXRPC3",@^%ZOSF("TRAP") + S BMXI=BMXI+1 + I BMXNTNM="" S ^BMXTMP($J,BMXI)="^" Q + S BMXNTID=$O(^BMXUSER("B",BMXNTNAM,0)) + I '+BMXNTID S ^BMXTMP($J,BMXI)="^" Q + S BMXNOD=$G(^BMXUSER(BMXNTID,0)) + S BMXA=$P(BMXNOD,U,2) + S BMXV=$P(BMXNOD,U,3) + S ^BMXTMP($J,BMXI)=BMXA_"^"_BMXV_"^" + Q + ; +WINUGET(BMXWINID) ;EP + ;Returns DUZ for user having Windows Identity BMXWINID + ;Returns 0 if no Windows user found + ; + N BMXIEN,BMXNOD,BMXDUZ + I BMXWINID="" Q 0 + S BMXIEN=$O(^BMXUSER("B",BMXWINID,0)) + I '+BMXIEN Q 0 + S BMXNOD=$G(^BMXUSER(BMXIEN,0)) + S BMXDUZ=$P(BMXNOD,U,2) + Q BMXDUZ + ; +NTUSET(BMXY,BMXNTNAM) ;EP + ;Sets NEW PERSON map entry for Windows Identity BMXNTNM + ;Returns ERRORID 0 if all ok + ;Called by RPC BMXNetSetUser + ; + ; + N BMXI,BMXNTID,BMXFDA,BMXF,BMXIEN,BMXMSG,BMXAPPTD + S BMXI=0 + S BMXY="^BMXTMP("_$J_")" + S X="NTUET^BMXRPC3",@^%ZOSF("TRAP") + S BMXI=BMXI+1 + ; Quit with error if no DUZ exists + I '+$G(DUZ) D NTUERR(BMXI,500) Q + ; Create entry or file in existing entry in BMX USER + I $D(^BMXUSER("B",BMXNTNAM)) S BMXF="?1," + E S BMXF="+1," + S BMXFDA(90093.1,BMXF,.01)=BMXNTNAM + S BMXFDA(90093.1,BMXF,.02)=$G(DUZ) + K BMXIEN,BMXMSG + D UPDATE^DIE("","BMXFDA","BMXIEN","BMXMSG") + S BMXAPPTD=+$G(BMXIEN(1)) + S BMXI=BMXI+1 + S ^BMXTMP($J,BMXI)=BMXAPPTD_"^0" + Q + ; +NTUET ;EP + ;Error trap from REGEVNT + ; + I '$D(BMXI) N BMXI S BMXI=999 + S BMXI=BMXI+1 + D NTUERR(BMXI,99) + Q + ; +NTUERR(BMXI,BMXERID) ;Error processing + S BMXI=BMXI+1 + S ^BMXTMP($J,BMXI)="^"_BMXERID + Q + ; + ; +NTU1 ;S BMXCOL="T00030NT_DOMAIN^T00030NT_USERNAME^T00030RPMS_USERNAME"_$C(30) + ;S RESULT=BMXCOL_BMXDOM_U_BMXNAM_U_BMXRNAM_$C(30)_$C(31) + Q + ; +GETFC(BMXFACS,DUZ) ;Gets all facilities for a user -- *1000 - Changes to support VISTA + ; Input DUZ - user IEN from the NEW PERSON FILE + ; Output - Number of facilities;facility1 name&facility1 IEN;...facilityN&facilityN IEN + N BMXFN,BMXN + S BMXFN=0,BMXFACS="" + F BMXN=1:1 S BMXFN=$O(^VA(200,DUZ,2,BMXFN)) Q:BMXFN="" D + . S:BMXN>1 BMXFACS=BMXFACS_";" S BMXFACS=BMXFACS_$P(^DIC(4,BMXFN,0),U,1)_"&"_BMXFN + ;//smh I BMXN=1 S BMXFN=$P(^AUTTSITE(1,0),U,1) D + ;//smh . S BMXFACS=BMXFACS_$P(^DIC(4,BMXFN,0),U,1)_"&"_BMXFN + S BMXFACS=BMXN-(BMXN>1)_";"_BMXFACS + Q + ; +GETFCRS(BMXFACS,BMXDUZ) ;Gets all facilities for a user - returns RECORDSET -- *1000 - Changes to support VISTA + ; + ;TODO: return as global array, add error checking + N BMXFN,BMXN,BMXSUB,BMXRCNT + S BMXDUZ=$TR(BMXDUZ,$C(13),"") + S BMXDUZ=$TR(BMXDUZ,$C(10),"") + S BMXDUZ=$TR(BMXDUZ,$C(9),"") + S BMXFN=0 + S BMXSUB="^VA(200,"_BMXDUZ_",2," + S BMXFACS="T00030FACILITY_NAME^T00030FACILITY_IEN^T00002MOST_RECENT_LOOKUP"_$C(30) + ;F BMXN=1:1 S BMXFN=$O(^VA(200,BMXDUZ,2,BMXFN)) Q:BMXFN="" D + S BMXRCNT=0 ;cmi/maw mod 10/17/2006 + F BMXN=1:1 S BMXFN=$O(^VA(200,BMXDUZ,2,BMXFN)) Q:'BMXFN D ;IHS/ANMC/LJF 8/9/01 + . ;S BMXFACS=BMXFACS_$P(^DIC(4,BMXFN,0),U,1)_"^"_BMXFN_$C(30) + . S BMXFACS=BMXFACS_$P(^DIC(4,BMXFN,0),U,1)_"^"_BMXFN + . ;S BMXRCNT=0 ;cmi/maw orig + . ;I $D(^DISV(BMXDUZ,BMXSUB)),^DISV(BMXDUZ,BMXSUB)=BMXFN S BMXRCNT=1 + . ;I $G(DUZ(2))=BMXFN S BMXRCNT=1 ;cmi/maw orig + . S BMXRCNT=BMXRCNT+1 ;cmi/maw mod + . S BMXFACS=BMXFACS_"^"_BMXRCNT_$C(30) + ;//smh I BMXN=1 S BMXFN=$P(^AUTTSITE(1,0),U,1) D + ;//smh . S BMXFACS=BMXFACS_$P(^DIC(4,BMXFN,0),U,1)_"^"_BMXFN_"^"_1_$C(30) + S BMXFACS=BMXFACS_$C(31) + Q + ; +SETFCRS(BMXY,BMXFAC) ; + ; + ;Sets DUZ(2) to value in BMXFAC + ;Fails if BMXFAC is not one of the current user's divisions + ;Returns Recordset + ; + S X="ERFC^BMXRPC3",@^%ZOSF("TRAP") + S BMXY="T00030DUZ^T00030FACILITY_IEN^T00030FACILITY_NAME"_$C(30) + N BMXSUB,BMXFACN + I '+DUZ S BMXY=BMXY_0_"^"_0_"^"_0_$C(30)_$C(31) Q + I '+BMXFAC S BMXY=BMXY_DUZ_"^"_0_"^"_0_$C(30)_$C(31) Q + ;I '$D(^VA(200,DUZ,2,+BMXFAC,0)) S BMXY=BMXY_DUZ_"^"_0_"^"_0_$C(30)_$C(31) Q ; GIS/OIT Feb 9, 2010 + S DUZ(2)=BMXFAC ;IHS/OIT/HMW SAC Exemption Applied For + S BMXFACN=$G(^DIC(4,+DUZ(2),0)) + S BMXFACN=$P(BMXFACN,"^") + S BMXSUB="^VA(200,"_DUZ_",2," + S ^DISV(DUZ,BMXSUB)=BMXFAC + S BMXY=BMXY_DUZ_"^"_BMXFAC_"^"_BMXFACN_$C(30)_$C(31) + Q + ; +ERFC ; + D ^%ZTER + S BMXY=$G(BMXY)_0_"^"_0_$C(30)_$C(31) Q + Q + ; +SETFC(BMXY,BMXFAC) ; + ;Sets DUZ(2) to value in BMXFAC + ;Fails if BMXFAC is not one of the current user's divisions + ;Returns 1 if successful, 0 if failed + ; + S BMXY=0 + N BMXSUB + I '+DUZ S BMXY=0 Q + I '+BMXFAC S BMXY=0 Q + I '$D(^VA(200,DUZ,2,+BMXFAC,0)) S BMXY=0 Q + S DUZ(2)=BMXFAC ;IHS/OIT/HMW SAC Exemption Applied For + S BMXSUB="^VA(200,"_DUZ_",2," + S ^DISV(DUZ,BMXSUB)=BMXFAC + S BMXY=1 + Q + ; +APSEC(BMXY,BMXKEY) ;EP + ;Return IHSCD_SUCCEEDED (-1) if user has key BMXKEY + ;OR if user has key XUPROGMODE + ;Otherwise, returns IHSCD_FAILED (0) + N BMXIEN,BMXPROG,BMXPKEY + I '$G(DUZ) S BMXY=0 Q + I BMXKEY="" S BMXY=0 Q + ; + ;Test for programmer mode key + S BMXPROG=0 + I $D(^DIC(19.1,"B","XUPROGMODE")) D + . S BMXPKEY=$O(^DIC(19.1,"B","XUPROGMODE",0)) + . I '+BMXPKEY Q + . I '$D(^VA(200,DUZ,51,BMXPKEY,0)) Q + . S BMXPROG=1 + I BMXPROG S BMXY=-1 Q + ; + I '$D(^DIC(19.1,"B",BMXKEY)) S BMXY=0 Q + S BMXIEN=$O(^DIC(19.1,"B",BMXKEY,0)) + I '+BMXIEN S BMXY=0 Q + I '$D(^VA(200,DUZ,51,BMXIEN,0)) S BMXY=0 Q + S BMXY=-1 + Q + ; +SIGCHK(BMXY,BMXSIG) ;EP + ;Checks BMXSIG against hashed value in NEW PERSON + ;Return IHSCD_SUCCEEDED (-1) if BMXSIG matches + ;Otherwise, returns IHSCD_FAILED (0) + N X + S BMXY=0 + I '$G(DUZ) Q + I '$D(^VA(200,DUZ,20)) Q ;TODO What if no signature? + S BMXHSH=$P(^VA(200,DUZ,20),U,4) + S X=$G(BMXSIG) + D HASH^XUSHSHP + I X=BMXHSH S BMXY=-1 + Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC4.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC4.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC4.m (revision 1147) @@ -0,0 +1,148 @@ +BMXRPC4 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ; + ;;4.1000;BMX;;Apr 17, 2011 + ; +PTINFORS(BMXY,BMXIEN) ;EP Patient Info Recordset + ; + N BMXDPT,BMXZ,BMXDLIM,BMXXX,BMXRET,BMXAGE,BMXNEXT,BMXSEX,BMXERR,BMXHRN + S BMXDLIM="^",BMXERR="" + S BMXRET="T00030NAME^T00030HRN^T00030SSN^D00030DOB^T00030IEN^T00020AGE^T00080NEXT_APPT^T00010SEX"_$C(30) + I '$D(DUZ(2)) S BMXY=BMXRET_$C(31)_"No DUZ2" Q + I +$G(DUZ) D + . S ^DISV(DUZ,"^AUPNPAT(")=BMXIEN + . S ^DISV(DUZ,"^DPT(")=BMXIEN + I '$D(^DPT(BMXIEN)) S BMXY=BMXRET_$C(31)_"No such patient" Q + S BMXDPT=$G(^DPT(BMXIEN,0)) + S BMXZ=$P(BMXDPT,U) ;NAME + ;S $P(BMXZ,BMXDLIM,2)=$P($G(^AUPNPAT(BMXIEN,41,DUZ(2),0)),U,2) ;CHART + S BMXHRN=$P($G(^AUPNPAT(BMXIEN,41,DUZ(2),0)),U,2) ;CHART + ;I BMXHRN="" Q ;NO CHART AT THIS DUZ2 + I $P($G(^AUPNPAT(BMXIEN,41,DUZ(2),0)),U,3) S BMXHRN=BMXHRN_"(*)" + S $P(BMXZ,BMXDLIM,2)=BMXHRN + ; + S $P(BMXZ,BMXDLIM,3)=$P(BMXDPT,U,9) ;SSN + S Y=$P(BMXDPT,U,3) X ^DD("DD") + S $P(BMXZ,BMXDLIM,4)=Y ;DOB + S $P(BMXZ,BMXDLIM,5)=BMXIEN + S BMXAGE=$$AGEF^BMXUTL1(BMXIEN) + S $P(BMXZ,BMXDLIM,6)=BMXAGE + S BMXNEXT=$$NEXTAPPT^BMXUTL2(BMXIEN) + S $P(BMXZ,BMXDLIM,7)=BMXNEXT + S BMXSEX=$$SEXW^BMXUTL1(BMXIEN) + S $P(BMXZ,BMXDLIM,8)=BMXSEX + S BMXRET=BMXRET_BMXZ + S BMXY=BMXRET_$C(30)_$C(31)_BMXERR + Q + ; +PTLOOKRS(BMXY,BMXP,BMXC) ;EP Patient Lookup + ; + ;Find up to BMXC patients matching BMXP* + ;Supports DOB Lookup, SSN Lookup + ; + ;S ^HW("PTLOOK","INPUT")=BMXP + ;S ^HW("PTLOOK","DUZ2")=$G(DUZ(2)) + S BMXP=$TR(BMXP,$C(13),"") + S BMXP=$TR(BMXP,$C(10),"") + S BMXP=$TR(BMXP,$C(9),"") + S:BMXC="" BMXC=10 + N BMXHRN,BMXZ,BMXDLIM,BMXRET + S BMXDLIM="^" + S BMXRET="T00030NAME^T00030HRN^T00030SSN^D00030DOB^T00030IEN"_$C(30) + I '+$G(DUZ) S BMXY=BMXRET_$C(31) Q + I '$D(DUZ(2)) S BMXY=BMXRET_$C(31) Q +DOB ;DOB Lookup + I +DUZ(2),((BMXP?1.2N1"/"1.2N1"/"1.4N)!(BMXP?1.2N1" "1.2N1" "1.4N)!(BMXP?1.2N1"-"1.2N1"-"1.4N)) D S BMXY=BMXRET_$C(31) Q + . S X=BMXP S %DT="P" D ^%DT S BMXP=Y Q:'+Y + . Q:'$D(^DPT("ADOB",BMXP)) + . S BMXIEN=0,BMXXX=1 F S BMXIEN=$O(^DPT("ADOB",BMXP,BMXIEN)) Q:'+BMXIEN D + . . Q:'$D(^DPT(BMXIEN,0)) + . . S BMXDPT=$G(^DPT(BMXIEN,0)) + . . S BMXZ=$P(BMXDPT,U) ;NAME + . . ;S $P(BMXZ,BMXDLIM,2)=$P($G(^AUPNPAT(BMXIEN,41,DUZ(2),0)),U,2) ;CHART + . . S BMXHRN=$P($G(^AUPNPAT(BMXIEN,41,DUZ(2),0)),U,2) ;CHART + . . I BMXHRN="" Q ;NO CHART AT THIS DUZ2 + . . I $P($G(^AUPNPAT(BMXIEN,41,DUZ(2),0)),U,3) S BMXHRN=BMXHRN_"(*)" + . . S $P(BMXZ,BMXDLIM,2)=BMXHRN + . . ; + . . S $P(BMXZ,BMXDLIM,3)=$P(BMXDPT,U,9) ;SSN + . . S Y=$P(BMXDPT,U,3) X ^DD("DD") + . . S $P(BMXZ,BMXDLIM,4)=Y ;DOB + . . S $P(BMXZ,BMXDLIM,5)=BMXIEN + . . S BMXXX=BMXXX+1 + . . ;S $P(BMXRET,$C(30),BMXXX)=BMXZ + . . S BMXRET=BMXRET_BMXZ_$C(30) + . . Q + . Q + ; + ;Chart# Lookup + I +DUZ(2),BMXP]"",$D(^AUPNPAT("D",BMXP)) D S BMXY=BMXRET_$C(30)_$C(31) Q + . S BMXIEN=0 F S BMXIEN=$O(^AUPNPAT("D",BMXP,BMXIEN)) Q:'+BMXIEN I $D(^AUPNPAT("D",BMXP,BMXIEN,DUZ(2))) D Q + . . Q:'$D(^DPT(BMXIEN,0)) + . . S BMXDPT=$G(^DPT(BMXIEN,0)) + . . S BMXZ=$P(BMXDPT,U) ;NAME + . . ;S $P(BMXZ,BMXDLIM,2)=BMXP ;CHART + . . S BMXHRN=BMXP ;CHART + . . I $D(^AUPNPAT(BMXIEN,41,DUZ(2),0)),$P(^(0),U,3) S BMXHRN=BMXHRN_"(*)" + . . S $P(BMXZ,BMXDLIM,2)=BMXHRN + . . S $P(BMXZ,BMXDLIM,3)=$P(BMXDPT,U,9) ;SSN + . . S Y=$P(BMXDPT,U,3) X ^DD("DD") + . . S $P(BMXZ,BMXDLIM,4)=Y ;DOB + . . S $P(BMXZ,BMXDLIM,5)=BMXIEN + . . S $P(BMXRET,$C(30),2)=BMXZ + . . Q + . Q + ; + ;SSN Lookup + I (BMXP?9N)!(BMXP?3N1"-"2N1"-"4N),$D(^DPT("SSN",BMXP)) D S BMXY=BMXRET_$C(30)_$C(31) Q + . S BMXIEN=0 F S BMXIEN=$O(^DPT("SSN",BMXP,BMXIEN)) Q:'+BMXIEN D Q + . . Q:'$D(^DPT(BMXIEN,0)) + . . S BMXDPT=$G(^DPT(BMXIEN,0)) + . . S BMXZ=$P(BMXDPT,U) ;NAME + . . S BMXHRN=$P($G(^AUPNPAT(BMXIEN,41,DUZ(2),0)),U,2) ;CHART + . . I BMXHRN="" Q ;NO CHART AT THIS DUZ2 + . . I $P($G(^AUPNPAT(BMXIEN,41,DUZ(2),0)),U,3) S BMXHRN=BMXHRN_"(*)" + . . S $P(BMXZ,BMXDLIM,2)=BMXHRN + . . S $P(BMXZ,BMXDLIM,3)=$P(BMXDPT,U,9) ;SSN + . . S Y=$P(BMXDPT,U,3) X ^DD("DD") + . . S $P(BMXZ,BMXDLIM,4)=Y ;DOB + . . S $P(BMXZ,BMXDLIM,5)=BMXIEN + . . S $P(BMXRET,$C(30),2)=BMXZ + . . Q + . Q + ; + S BMXFILE=9000001 + S BMXIENS="" + S BMXFLDS=".01" + S BMXFLAGS="M" + S BMXVALUE=BMXP + S BMXNMBR=BMXC + S BMXIXS="" + S BMXSCRN=$S(+DUZ(2):"I $D(^AUPNPAT(Y,41,DUZ(2),0))",1:"") + ;I BMXSCRN]"" S DIC("S")=BMXSCRN + ;S BMXSCRN="I 0" + S BMXIDEN="" + S BMXTARG="BMXRSLT" + S BMXMSG="" + D FIND^DIC(BMXFILE,BMXIENS,BMXFLDS,BMXFLAGS,BMXVALUE,BMXNMBR,BMXIXS,BMXSCRN,BMXIDEN,BMXTARG,BMXMSG) + ;S BMXRET="" + ;B + I '+$G(BMXRSLT("DILIST",0)) S BMXY=BMXRET_$C(31) Q + F BMXX=1:1:$P(BMXRSLT("DILIST",0),U) D + . ;B + . S BMXIEN=BMXRSLT("DILIST",2,BMXX) + . S BMXZ=BMXRSLT("DILIST","ID",BMXX,.01) ;NAME + . ;S $P(BMXZ,BMXDLIM,2)=$P($G(^AUPNPAT(BMXIEN,41,DUZ(2),0)),U,2) ;CHART + . S BMXHRN=$P($G(^AUPNPAT(BMXIEN,41,DUZ(2),0)),U,2) ;CHART + . I BMXHRN="" Q ;NO CHART AT THIS DUZ2 + . I $P($G(^AUPNPAT(BMXIEN,41,DUZ(2),0)),U,3) S BMXHRN=BMXHRN_"(*)" + . S $P(BMXZ,BMXDLIM,2)=BMXHRN + . S BMXDPT=$G(^DPT(BMXIEN,0)) + . S $P(BMXZ,BMXDLIM,3)=$P(BMXDPT,U,9) ;SSN + . S Y=$P(BMXDPT,U,3) X ^DD("DD") + . S $P(BMXZ,BMXDLIM,4)=Y ;DOB + . S $P(BMXZ,BMXDLIM,5)=BMXIEN + . S $P(BMXRET,$C(30),BMXX+1)=BMXZ + . Q + ;K BMXRSLT + S BMXY=BMXRET_$C(30)_$C(31) + Q +ZZZ ; Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC5.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC5.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC5.m (revision 1147) @@ -0,0 +1,124 @@ +BMXRPC5 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + ;Stolen from Mike Remillard. If it doesn't work, it's his fault. +HS(BMXGBL,BMXDFN,BMXTYPE,BMXRDL,BMXFDL) ;EP + ;---> Return patient's Health Summary in global array, ^BMXTEMP($J,"HS" + ;---> Lines delimited by BMXRDL + ;---> File delimited by BMXFDL + ;---> Called by RPC: BMX HEALTH SUMMARY + ;---> Parameters: + ; 1 - BMXGBL (ret) Name of result global containing patient's + ; Health Summary, passed to Broker. + ; 2 - BMXDFN (req) DFN of patient. + ; + ;---> Delimiter to pass error with result to GUI. + N BMX30,BMX31,BMXERR,X + ;S BMX30=$C(30),BMX31=$C(31)_$C(31) + S BMX30=$G(BMXRDL) + I BMX30="" S BMX30=$C(13)_$C(10) + S BMX31=$G(BMXFDL) + S BMXGBL="^BMXTEMP("_$J_",""HS"")",BMXERR="" + K ^BMXTEMP($J,"HS") + ; + N BMXPATH + ;---> Should get path from a Site Parameter. For now, use MSM default. + S BMXPATH="/usr/spool/uucppublic/" + ;S BMXPATH="C:\MSM\" ;TODO: Change to site parameter + ;--->Flag to test whether running as broker job: + N BMXSOCK + S BMXSOCK=0 + ;I $I=56 S BMXSOCK=1 + ; + ;---> If DFN not supplied, set Error Code and quit. + I '$G(BMXDFN) D Q + . S BMXERR="No Patient DFN" S ^BMXTEMP($J,"HS",I)=BMX31_BMXERR + ; + ;---> If patient does not exist, set Error Code and quit. + I '$D(^AUPNPAT(BMXDFN,0)) D Q + . S BMXERR="Patient DFN does not exist" S ^BMXTEMP($J,"HS",I)=BMX31_BMXERR + ; + N APCHSPAT,APCHSTYP + S APCHSPAT=BMXDFN + S APCHSTYP=$G(BMXTYPE) + S:'+APCHSTYP APCHSTYP=7 + ;S APCHSTYP=9 + ;---> Doesn't work from Device 56. + ;D GUIR^XBLM("EN^APCHS","^TMP(""BMXHS"",$J,") + ; + ;---> Generate a host file name. + N BMXFN S BMXFN="XB"_$J + ; + D + .;---> Important to preserve IO variables for when $I returns to 56. + .N IO,IOBS,IOF,IOHG,IOM,ION,IOPAR,IOS,IOSL,IOST,IOT,IOUPAR,IOXY + .; + .;---> Open host file to receive legacy code display. + .S Y=$$OPEN^%ZISH(BMXPATH,BMXFN,"W") + .;O 51:(BMXPATH_BMXFN:"W") + .;S IO=51,IOST="P-OTHER80" + .;K ^HW("HS") + .;S ^HW("HS","IOST")=$G(IOST) + .;S ^HW("HS","IO")=$G(IO) + .; + .;---> Call to legacy code for Health Summary display. + .S IOSL=999,IOM=80 + .D EN^APCHS + .;---> Write End of File (EOF) marker. + .W $C(9) + .; + .;---> %ZISC doesn't close Device 51 when called from TCPIP socket? + .;D ^%ZISC + .;---> Buffer won't write out to file until the device is closed + .;---> or the buffer is flushed by some other command. + .;---> At this point, host file exists but has 0 bytes. + .;C 51 + .;---> Now host file contains legacy code display data. + .; + .;---> For some reason %ZISH cannot open the host file a second time. + .;S Y=$$OPEN^%ZISH(BMXPATH,BMXFN,"R") + .;O 51:(BMXPATH_BMXFN:"R") + .U 51 + .; + .;---> Read in the host file. + .D + ..;---> Stop reading Host File if line contains EOF $C(9). + ..;N I,Y F I=1:1 R Y Q:Y[$C(9) S ^TMP("BMXHS",$J,I)=Y + .; + .;---> %ZISC doesn't close Device 51 when called from TCPIP socket? + .;D ^%ZISC + .;C 51 + ; + ;---> At this point $I=1. The job has "forgotten" its $I, even + ;---> though %SS shows 56 as the current device. $I=1 causes a + ;---> at CAPI+10^XWBBRK2. A simple USE 56 command + ;---> appears to "remind" the job its $I is 56, and it works. + ;---> Possibly this is something %ZISC ordinarily does. + I BMXSOCK U 56 + ;U 56 + ; + ;---> Copy Health Summary to global array for passing back to GUI. + N I,N,U,X S U="^" + S N=0 + F I=1:1 S N=$O(^TMP("BMXHS",$J,N)) Q:'N D + .;---> Set null lines (line breaks) equal to one space, so that + .;---> Windows reader will quit only at the final "null" line. + .S X=^TMP("BMXHS",$J,N) S:X="" X=" " + .S ^BMXTEMP($J,"HS",I)=X_BMX30 + ; + ;---> If no Health Summary produced, report it as an error. + D:'$O(^BMXTEMP($J,"HS",0)) + . S BMXERR="No Health Summary produced" S ^BMXTEMP($J,"HS",I)=BMX31_BMXERR + ; + ;---> Tack on Error Delimiter and any error. + S ^BMXTEMP($J,"HS",I)=BMX31_BMXERR + ; + ;---> Delete host file. + ;---> This doesn't work. + S Y=$$DEL^%ZISH(BMXPATH,BMXFN) + ;---> Call system command. + ;S ^MIKE(1)=BMXPATH + ;S ^MIKE(2)=BMXFN + ;S Y=$ZOS(2,BMXPATH_BMXFN) + K ^TMP("BMXHS",$J) + Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC6.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC6.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC6.m (revision 1147) @@ -0,0 +1,112 @@ +BMXRPC6 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; +USRKEYRS(BMXY,BMXDUZ) ;EP - Returns recordset of user's keys + ; + N BMXDPT,BMXZ,BMXDLIM,BMXXX,BMXRET,BMXAGE,BMXNEXT,BMXSEX,BMXERR + S BMXDLIM="^",BMXERR="" + S BMXRET="T00050KEY"_$C(30) + I '$D(DUZ(2)) S BMXY=BMXRET_$C(31)_"No DUZ2" Q + ;Strip CRLFs from parameter + S BMXCRLF=$C(13)_$C(10) + S BMXDUZ=$TR(BMXDUZ,BMXCRLF,"") + I '$D(^VA(200,BMXDUZ)) S BMXY=BMXRET_$C(31)_"No such user" Q + S BMXK=0 F S BMXK=$O(^VA(200,BMXDUZ,51,BMXK)) Q:'+BMXK D + . S BMXKEY=$G(^VA(200,BMXDUZ,51,BMXK,0)) + . Q:BMXKEY="" + . S BMXKEY=$P(BMXKEY,BMXDLIM) + . Q:'+BMXKEY + . Q:'$D(^DIC(19.1,BMXKEY,0)) + . S BMXKEY=$P(^DIC(19.1,BMXKEY,0),BMXDLIM) + . Q:BMXKEY']"" + . S BMXRET=BMXRET_BMXKEY_$C(30) + S BMXY=BMXRET_$C(30)_$C(31)_BMXERR + Q + ; +PDATA(BMXY,BMXP) ;-EP Returns patient demographics for pt with + ;health record number BMXP at the current DUZ(2) + N BMXIEN,BMXDUZ2,BMXSQL + ;Strip CR, LF, TAB, SPACE + S BMXP=$TR(BMXP,$C(13),"") + S BMXP=$TR(BMXP,$C(10),"") + S BMXP=$TR(BMXP,$C(9),"") + S BMXP=$TR(BMXP,$C(32),"") + S BMXDUZ2=$G(DUZ(2)),BMXDUZ2=+BMXDUZ2 + S BMXIEN=0 + I +BMXDUZ2 F S BMXIEN=$O(^AUPNPAT("D",BMXP,BMXIEN)) Q:'+BMXIEN I $D(^AUPNPAT("D",BMXP,BMXIEN,BMXDUZ2)) Q + S BMXSQL="SELECT NAME 'Name', DOB 'DateOfBirth', TRIBE_OF_MEMBERSHIP 'Tribe', MAILING_ADDRESS-STREET 'Street'," + S BMXSQL=BMXSQL_" MAILING_ADDRESS-CITY 'City', MAILING_ADDRESS-STATE 'State', MAILING_ADDRESS-ZIP 'Zip', HOME_PHONE 'HomePhone', OFFICE_PHONE 'WorkPhone' FROM PATIENT WHERE BMXIEN='"_+BMXIEN_"'" + D SQL^BMXSQL(.BMXY,BMXSQL) + S @BMXY@(.5)="T00015Chart^" + I $D(@BMXY@(10)) S @BMXY@(10)=BMXP_"^"_@BMXY@(10) + ; + Q + ; +PDEMOD(BMXY,BMXPAT,BMXCOUNT) ;EP + ;Entry point for Serenji debugging + ; + ;D DEBUG^%Serenji("PDEMOD^BMXRPC6(.BMXY,BMXPAT,BMXCOUNT)") + Q + ; +PDEMO(BMXY,BMXPAT,BMXCOUNT) ;EP + ;This simple RPC demonstrates how to format data + ;for the BMXNet ADO.NET data provider + ; + ;Returns a maximum of BMXCOUNT records from the + ;VA PATIENT file whose names begin with BMXPAT + ; + N BMXI,BMXD,BMXC,BMXNODE,BMXDOB + ; + ;When the VA BROKER calls this routine, BMXY is passed by reference + ;We set BMXY to the value of the variable in which we will return + ;our data: + ;S BMXY="^TMP(""BMX"","_$J_")" + N BMXUID + S BMXUID=$S($G(ZTSK):"Z"_ZTSK,1:$J) + S BMXY=$NA(^BMXTMP("BMXTEST",BMXUID)) + K ^BMXTMP("BMXTEST",BMXUID) + ; + ;The first subnode of the data global contains the column header information + ;in the form "TxxxxxCOLUMN1NAME^txxxxxCOLUMN2NAME"_$C(30) + ;where T is the column data type and can be either T for text, I for numeric or D for date/time. + ;xxxxx is the length of the column in characters: + ; + S BMXI=0,BMXC=0 + S ^BMXTMP("BMXTEST",BMXUID,BMXI)="T00030NAME^T00010SEX^D00020DOB"_$C(30) + ; + ;You MUST set an error trap: + S X="PDERR^BMXRPC6",@^%ZOSF("TRAP") + ; + ;Strip CR, LF, TAB, SPACE from BMXCOUNT parameter + S BMXCOUNT=$TR(BMXCOUNT,$C(13),"") + S BMXCOUNT=$TR(BMXCOUNT,$C(10),"") + S BMXCOUNT=$TR(BMXCOUNT,$C(9),"") + S BMXCOUNT=$TR(BMXCOUNT,$C(32),"") + ; + ;Iterate through the global and set the data nodes: + S:BMXPAT="" BMXPAT="A" + S BMXPAT=$O(^DPT("B",BMXPAT),-1) + S BMXD=0 + F S BMXPAT=$O(^DPT("B",BMXPAT)) Q:BMXPAT="" S BMXD=$O(^DPT("B",BMXPAT,0)) I +BMXD S BMXC=BMXC+1 Q:(BMXCOUNT)&(BMXC>BMXCOUNT) D + . Q:'$D(^DPT(BMXD,0)) + . S BMXI=BMXI+1 + . S BMXNODE=^DPT(BMXD,0) + . ;Convert the DOB from FM date + . S Y=$P(BMXNODE,U,3) + . I +Y X ^DD("DD") + . S BMXDOB=Y + . ;The data node fields are in the same order as the column header, i.e. NAME^SEX^DOB + . ;and terminated with a $C(30) + . S ^BMXTMP("BMXTEST",BMXUID,BMXI)=$P(BMXNODE,U)_U_$P(BMXNODE,U,2)_U_BMXDOB_$C(30) + ; + ;After all the data nodes have been set, set the final node to $C(31) to indicate + ;the end of the recordset + S BMXI=BMXI+1 + S ^BMXTMP("BMXTEST",BMXUID,BMXI)=$C(31) + Q + ; +PDERR ;Error trap for PDEMO + ; + S ^BMXTMP("BMXTEST",BMXUID,BMXI+1)=$C(31) + Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC7.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC7.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC7.m (revision 1147) @@ -0,0 +1,135 @@ +BMXRPC7 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; +WINVAL(BMXRET,BMXWINID) ;EP + ;Validates user based on Windows Identity + ; + ;Return R(0)=DUZ, R(1)=(0=OK, 1,2...=Can't sign-on for some reason) + ; R(2)=verify needs changing, R(3)=Message, R(4)=0, R(5)=msg cnt, R(5+n) + ; R(R(5)+6)=# div user must select from, R(R(5)+6+n)=div + I $$NEWERR^%ZTER N $ETRAP S $ETRAP="" ; IHS/OIT/HMW SAC Exemption Applied For + N X,BMXUSER,BMXUNOW,BMXUM,BMXUMSG,BMXVCOK + S %="DUZ" K @% + S BMXRET(0)=0,BMXRET(5)=0,BMXUM=0,BMXUMSG=0 + S DUZ=0,DUZ(0)="",BMXVCOK=0 D NOW ;IHS/OIT/HMW SAC Exemption Applied For + S BMXUMSG=$$INHIBIT() I BMXUMSG S BMXUM=1 G VAX ;Logon inhibited + ; + S DUZ=$$WINUGET^BMXRPC3(BMXWINID) ;IHS/OIT/HMW SAC Exemption Applied For + I DUZ>0 D USER(DUZ) + S BMXUMSG=$$UVALID() G:BMXUMSG VAX + I DUZ>0 S BMXUMSG=$$POST(1) +VAX S:BMXUMSG>0 DUZ=0 D:DUZ>0 POST2 + S BMXRET(0)=DUZ,BMXRET(1)=BMXUM,BMXRET(2)=BMXVCOK,BMXRET(3)=$S(BMXUMSG:$$TXT(BMXUMSG),1:""),BMXRET(4)=0 + Q + ; +NOW S U="^",BMXUNOW=$$NOW^XLFDT(),DT=$P(BMXUNOW,".") + Q + ; +USER(IX) ;Build USER + S BMXUSER(0)=$G(^VA(200,+IX,0)),BMXUSER(1)=$G(^(.1)) + Q + ; +POST(CVC) ;Finish setup partition, I CVC don't log get + N X,BMXUM + K ^UTILITY($J),^TMP($J) + I '$D(USER(0)),DUZ D USER(DUZ) + S BMXUM=$$USER1A Q:BMXUM>0 BMXUM ;User can't sign on for some reason. + S BMXRET(5)=0 ;The next line sends the post sign-on msg + F BMXPT=1:1 Q:'$D(BMXUTEXT(BMXPT)) S BMXRET(5+BMXPT)=$E(BMXUTEXT(BMXPT),2,256),BMXRET(5)=BMXPT + S BMXRET(5)=0 ;This line stops the display of the msg. Remove this line to allow. + D:'$G(CVC) POST2 + Q 0 +POST2 D:'$D(BMXUNOW) NOW + D DUZ ;^XUS1A ;,SAVE^XUS1,LOG^XUS1,ABT^XQ12 + K BMXUTEXT,BMXOPT,BMXUER ;XUEON,XUEOFF,XUTT + Q + ; +DUZ ;Setup DUZ. SAC exemption applied for. + S:'$D(BMXUSER(0)) BMXUSER(0)=^VA(200,DUZ,0) D:$D(BMXOPT)[0 BMXOPT + S DUZ(0)=$P(BMXUSER(0),U,4),DUZ(1)="",DUZ("AUTO")=$P(BMXOPT,"^",6) ;IHS/OIT/HMW SAC Exemption Applied For + S DUZ(2)=$S($G(DUZ(2))>0:DUZ(2),1:+$P(BMXOPT,U,17)) ;IHS/OIT/HMW SAC Exemption Applied For + S X=$P($G(^DIC(4,DUZ(2),99)),U,5),DUZ("AG")=$S(X]"":X,1:$P(^XTV(8989.3,1,0),U,8)) + S DUZ("BUF")=($P(BMXOPT,U,9)="Y"),DUZ("LANG")=$P(BMXOPT,U,7) ;IHS/OIT/HMW SAC Exemption Applied For + Q + ; +USER1A() ; + N BMXPTB,BMXPTE,BMXPTT + S BMXUTEXT=0,DUZ(2)=0 + F I=0:0 S I=$O(^XTV(8989.3,1,"POST",I)) Q:I'>0 D SET("!"_$G(^(I,0))) + D SET("!"),BMXOPT + S BMXPTH=$P($H,",",2) + D SET("!Good "_$S(BMXPTH<43200:"morning ",BMXPTH<61200:"afternoon ",1:"evening ")_$S($P(BMXUSER(1),U,4)]"":$P(BMXUSER(1),U,4),1:$P(BMXUSER(0),U,1))) + S BMXI1=$G(^VA(200,DUZ,1.1)),X=(+BMXI1_"0000") + I X D SET("! You last signed on "_$S(X\1=DT:"today",X\1+1=DT:"yesterday",1:$$DD(X))_" at "_$E(X,9,10)_":"_$E(X,11,12)) + I $P(BMXI1,"^",2) S I=$P(BMXI1,"^",2) D SET("!There "_$S(I>1:"were ",1:"was ")_I_" unsuccessful attempt"_$S(I>1:"s",1:"")_" since you last signed on.") + I $P(BMXUSER(0),U,12),$$PROHIBIT(BMXPTH,$P(BMXUSER(0),U,12)) Q 17 ;Time frame + I +$P(BMXOPT,U,15) S BMXPT=$P(BMXOPT,U,15)-($H-BMXUSER(1)) I BMXPT<6,BMXPT>0 D SET("! Your Verify code will expire in "_BMXPT_" days") + S:$P(BMXOPT,"^",5) XUTT=1 S:'$D(DTIME) DTIME=$P(BMXOPT,U,10) ; IHS/OIT/HMW SAC Exemption Applied For + I ('X)!$P(BMXOPT,U,4) Q 0 + Q 9 + ; +BMXOPT ;Build the BMXOPT string + N X,I + S:'$D(BMXOPT) BMXOPT=$G(^XTV(8989.3,1,"XUS")) + S X=$G(^VA(200,DUZ,200)) + F I=4:1:7,9,10 I $P(X,U,I)]"" S $P(BMXOPT,"^",I)=$P(X,U,I) + Q + ; +SET(V) ;Set into BMXUTEXT(BMXUTEXT) + S BMXUTEXT=$G(BMXUTEXT)+1,BMXUTEXT(BMXUTEXT)=V + Q + ; +PROHIBIT(BMXPTT,BMXPTR) ;See if a prohibited time, (Current time, restrict range) + N XMSG,BMXPTB,BMXPTE + S BMXPTT=BMXPTT\60#60+(BMXPTT\3600*100),BMXPTB=$P(BMXPTR,"-",1),BMXPTE=$P(BMXPTR,"-",2) + S XMSG=$P($$FMTE^XLFDT(DT_"."_BMXPTB,"2P")," ",2,3)_" thru "_$P($$FMTE^XLFDT(DT_"."_BMXPTE,"2P")," ",2,3) + I $S(BMXPTE'BMXPTE&(BMXPTT'BMXPTB!(BMXPTT0:^XTV(8989.3,1,4,X,0),1:BMXQVOL_"^y^1") S:$P(BMXVOL,U,6)="y" XRTL=BMXCI_","_BMXQVOL + ;I '$D(BMXQVOL) Q 0 + ;I '$D(BMXVOL) Q 0 + I $G(^%ZIS(14.5,"LOGON",BMXQVOL)) Q 1 + I $D(^%ZOSF("ACTJ")) X ^("ACTJ") I $P(BMXVOL,U,3),($P(BMXVOL,U,3)'>Y) Q 2 + Q 0 + ; + ; +UVALID() ;EF. Is it valid for this user to sign on? + I '+$G(BMXWIN) Q 18 + I DUZ'>0 Q 4 + I $P(BMXUSER(0),U,11),$P(BMXUSER(0),U,11)'>DT Q 11 ;Access Terminated + I $P(BMXUSER(0),U,7) Q 5 ;Disuser flag set + Q 0 + ; +DD(Y) Q $S($E(Y,4,5):$P("Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec","^",+$E(Y,4,5))_" ",1:"")_$S($E(Y,6,7):+$E(Y,6,7)_",",1:"")_($E(Y,1,3)+1700) + Q + ; +TXT(BMXPT) ; + S BMXPT=$T(ZZ+BMXPT) + S BMXPT=$P(BMXPT,";",4,9) I BMXPT["|" S BMXPT=$P(BMXPT,"|",1)_$G(BMXUM(0))_$P(BMXPT,"|",2) + Q BMXPT +ZZ ;;Halt;Error Messages +1 ;;1;Signons not currently allowed on this processor. +2 ;;1;Maximum number of users already signed on to this processor. +3 ;;1;This device has not been defined to the system -- contact system manager. +4 ;;0;Not a valid Windows Identity map value. +5 ;;0;No Access Allowed for this User. +6 ;;0;Invalid device password. +7 ;;0;Device locked due to too many invalid sign-on attempts. +8 ;;1;This device is out of service. +9 ;;0;*** MULTIPLE SIGN-ONS NOT ALLOWED *** +10 ;;1;You don't have access to this device! +11 ;;0;Your access code has been terminated. Please see your site manager! +12 ;;0;VERIFY CODE MUST be changed before continued use. +13 ;;1;This device may only be used outside of this time frame | +14 ;;0;'|' is not a valid UCI! +15 ;;0;'|' is not a valid program name! +16 ;;0;No PRIMARY MENU assigned to user or User is missing KEY to menu! +17 ;;0;Your access to the system is prohibited from |. +18 ;;0;Windows Integrated Security Not Allowed on this port. Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC8.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC8.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC8.m (revision 1147) @@ -0,0 +1,89 @@ +BMXRPC8 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; +BMXLOCKD(BMXY,BMXVAR,BMXINC,BMXTIME) ;EP + ;Entry point for debugging + ; + ;D DEBUG^%Serenji("BMXLOCKD^BMXRPC8(.BMXY,BMXVAR,BMXINC,BMXTIME)") + Q + ; +BMXLOCK(BMXY,BMXVAR,BMXINC,BMXTIME) ;EP + ;Called by BMX LOCK rpc to lock variable BMXVAR + ;If BMXVAR = "", argumentless lock is performed to release all locks + ;BMXINC = increment lock if "+", decrement if "-" + ;BMXTIME = lock timeout + ;Returns 1 if lock successful, otherwise 0; + ; + S X="ERR^BMXRPC8",@^%ZOSF("TRAP") + ; + N BMXC + S:$E(BMXVAR,1,1)="~" BMXVAR="^"_$E(BMXVAR,2,$L(BMXVAR)) + S:BMXTIME="" BMXTIME=0 + I BMXVAR="" X "L" S BMXY=1 Q + S BMXC="L " + S BMXC=BMXC_$S(BMXINC="+":"+",BMXINC="-":"-",1:"") + S BMXC=BMXC_BMXVAR_":"_+BMXTIME + X BMXC + S BMXY=$T + Q + ; +ERR ;Error processing + S BMXY=0 + Q + ; +BMXVERD(BMXY,BMXNS,BMXLOC) ;EP + ;Entry point for debugging + ; + ;D DEBUG^%Serenji("BMXVERD^BMXRPC8(.BMXY,BMXNS,BMXLOC)") + Q + ; +BMXVER(BMXY,BMXNS,BMXLOC) ;EP + ; + ;Called by BMX VERSION INFO rpc + ;Returns recordset of version info for server components in namespace BMXNS. + ;If BMXLOC is "", then the version info is assumed to be stored in piece 1-3 of + ;^APPL(1,0) + ; + ;TODO: + ;BMXLOC, if not null, is either a global reference such that $P(@BMXLOC,U,1,3) returns + ;MAJOR^MINOR^BUILD + ;Or BMXLOC can be an extrinsic function call that returns MAJOR^MINOR^BUILD. + ; + ;The returned error field is either "" or contains a text error message. + ; + N X,BMXI,BMXNOD,BMXDAT + ; + S X="VETRAP^BMXRPC8",@^%ZOSF("TRAP") + S BMXI=0 + K ^BMXTMP($J) + S BMXY="^BMXTMP("_$J_")" + S ^BMXTMP($J,BMXI)="T00030ERROR^T00030MAJOR_VERSION^T00030MINOR_VERSION^T00030BUILD"_$C(30) + S BMXI=BMXI+1 + I BMXNS="" D VERR(BMXI,"BMXRPC8: Invalid Null Application Namespace") Q + S BMXNOD="^"_BMXNS_"APPL(1,0)" + S BMXDAT=$G(@BMXNOD) + I BMXNS="" D VERR(BMXI,"BMXRPC8: No version info for Application Namespace") Q + S ^BMXTMP($J,BMXI)="^"_$P(BMXDAT,U,1,3)_$C(30) + Q + ; + ; +VERR(BMXI,BMXERR) ;Error processing + S BMXI=BMXI+1 + S ^BMXTMP($J,BMXI)=BMXERR_"^^^"_$C(30) + S BMXI=BMXI+1 + S ^BMXTMP($J,BMXI)=$C(31) + Q + ; +VETRAP ;EP Error trap entry + D ^%ZTER + I '$D(BMXI) N BMXI S BMXI=999999 + S BMXI=BMXI+1 + D VERR(BMXI,"BMXRPC8 Error: "_$G(%ZTERROR)) + Q + ; +IMHERE(BMXRES) ;EP + ;Entry point for BMX IM HERE remote procedure + S BMXRES=1 + Q + ; Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC9.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC9.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC9.m (revision 1147) @@ -0,0 +1,197 @@ +BMXRPC9 ; IHS/OIT/HMW - RPC CALL FOR EXTENDED BROKER FUNCTIONALITY ; + ;;4.1000;BMX;;Apr 17, 2011 + ; UPDATE FILEMAN WITH AN ADO RECORD SET FROM A WINDOWS APPLICATION + ; + ; + ; +SONLY(BMXY,BMXVAL) ;EP Schema Only + ; + I BMXVAL="TRUE" S BMX("SCHEMA ONLY")=1 + E S BMX("SCHEMA ONLY")=0 + S BMXY=BMX("SCHEMA ONLY") + ; + Q + ; + ; + ; +TESTADO(BMXOUT,HEADER,ROWDATA,ROWCOUNT,HANGSEC,ASYNCID) ; + ; ROWDATA IS | DELIMITED, REPLACE WITH ^ AND END> BMXIEN DONE FOR YOU + N BMXTMP,HANGTIME,BMXI,BMXGBL,INC + S U="^" + I $L($G(ASYNCID)) S BMXGBL=$NA(^BMXTMP("TESTADO",$G(ASYNCID),$J)) + E S BMXGBL=$NA(^BMXTMP("TESTADO",$J)) + K @BMXGBL + S BMXI=0 + S @BMXGBL@(BMXI)=$TR("I00010BMXIEN|"_HEADER,"|",U)_$C(30) + S ROWDATA=$TR(ROWDATA,"|",U)_$C(30) + F I=1:1:+$G(ROWCOUNT) D + . S BMXI=BMXI+1 + . S @BMXGBL@(BMXI)=I_U_ROWDATA + . Q + S BMXI=BMXI+1 + S @BMXGBL@(BMXI)=$C(31) + H +$G(HANGSEC) + S BMXOUT=BMXGBL + Q + ; +TESTECHO(BMXOUT,ECHO,REPEAT,HANGSEC) ; + I $L($G(REPEAT))=0 S REPEAT=1 + S REPEAT=+$G(REPEAT)-1 + S BMXOUT=ECHO + F I=1:1:REPEAT D + . S BMXOUT=BMXOUT_"~"_ECHO + . Q + H +$G(HANGSEC) + Q + ; +TESTRPC(BMXGBL,BMXSQL) ; + ;Test retrieval/update statement + ; + N BMXI,BMXERR,BMXN,BMXNOD,BMXNAM,BMXSEX,BMXDOB,BMXFAC,BMXTMP,BMXJ + S X="ETRAP^BMXRPC9",@^%ZOSF("TRAP") + S BMXGBL="^BMXTMP("_$J_")",BMXERR="",U="^" + K ^BMXTMP($J) + S BMXI=0 + ; + ;Old column info format: + ;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="I00010BMXIEN"_U_"D00010DOB"_U_"T00030LOCAL_FACLILITY"_U_"T00030NAME"_U_"T00010SEX"_$C(30) + ; + ;New column info format is @@@meta@@@KEYFIELD|FILE# + ; For each field: ^FILE#|FIELD#|DATATYPE|LENGTH|FIELDNAME|READONLY|KEYFIELD|NULL ALLOWED + ;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="@@@meta@@@" + ;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="BMXIEN|2160010^" + ;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="2160010|.001|I|10|BMXIEN|TRUE|TRUE^" + ;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="2160010|.03|D|10|DOB|FALSE|FALSE^" + ;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="2160010|.04|T|60|LOCAL_FACILITY|FALSE|FALSE^" + ;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="2160010|.01|T|30|NAME|FALSE|FALSE^" + ;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="2160010|.02|T|10|SEX|FALSE|FALSE" + ;S BMXI=BMXI+1,^BMXTMP($J,BMXI)=$C(30) + ; + D SS^BMXADO(.BMXTMP,"","TEST1") + I $G(BMXTMP)=$C(30) D ERR(99,"SCHEMA GENERATION FAILED") Q + S BMXJ=0 F S BMXJ=$O(BMXTMP(BMXJ)) Q:'+BMXJ D + . S BMXI=BMXI+1 + . S ^BMXTMP($J,BMXI)=BMXTMP(BMXJ) + I +$G(BMX("SCHEMA ONLY")) D Q + . S BMXI=BMXI+1 + . S ^BMXTMP($J,BMXI)=$C(31) + . Q + S BMXN=0 + F S BMXN=$O(^DIZ(2160010,BMXN)) Q:'+BMXN D + . Q:'$D(^DIZ(2160010,BMXN,0)) + . S BMXNOD=^DIZ(2160010,BMXN,0) + . S BMXNAM=$P(BMXNOD,U) + . S BMXSEX=$P(BMXNOD,U,2) + . S BMXDOB=$P(BMXNOD,U,3) + . S Y=BMXDOB X ^DD("DD") S BMXDOB=Y + . S BMXFAC=$P(BMXNOD,U,4) + . S:+BMXFAC BMXFAC=$P($G(^DIC(4,BMXFAC,0)),U) + . S BMXI=BMXI+1 + . S ^BMXTMP($J,BMXI)=BMXN_U_BMXDOB_U_BMXFAC_U_BMXNAM_U_BMXSEX_$C(30) + . Q + S BMXI=BMXI+1 + S ^BMXTMP($J,BMXI)=$C(31) + Q + ; +ERR(BMXID,BMXERR) ;Error processing + K ^BMXTMP($J) + S ^BMXTMP($J,0)="I00030ERRORID^T00030ERRORMSG"_$C(30) + S ^BMXTMP($J,1)=BMXID_"^"_BMXERR_$C(30) + S ^BMXTMP($J,2)=$C(31) + Q + ; +ETRAP ;EP Error trap entry + D ^%ZTER + D ERR(99,"BMXRPC9 Error: "_$G(%ZTERROR)) + Q + ; +TEST N OUT S OUT="" D ADO(.OUT,2160010,"1",(".01|A,A"_$C(30)_".02|M"_$C(30)_".03|1/5/1946"_$C(30)_".04|SAN XAVIER"_$C(31))) W !,OUT + Q + ; +ADOD(OUT,FILE,IEN,DATA) ; + ; + ;D DEBUG^%Serenji("ADOD^BMXRPC9(.OUT,FILE,IEN,DATA)") + ; + Q + ; +ADO(OUT,FILE,IEN,DATA) ; RPC CALL: OUT = OUTBOUND MESSAGE, FILE = FILEMAN FILE NUMBER, IEN = FILE INTERNAL ENTRY NUMBER, DATA = DATA STRING + N OREF,CREF,DIC,DIE,DA,DR,X,Y,%,FLD,CNT,FNO,VAL,TFLG,DFLG,TOT,UFLG,XTFLG,GTFLG,GDFLG + S OUT="",FLD="",GTFLG=0,GDFLG=0 + S IEN=$G(IEN) + I $E(IEN)="-" S IEN=$E(IEN,2,99),GDFLG=1 ; GLOBAL DELETE FLAG + I $E(IEN)="+" S IEN=$E(IEN,2,99),GTFLG=1 ; GLOBAL TRANSACTION FLAG, ROLLBACK IF ANY FIELD FAILS TO UPDATE + I IEN="Add"!(IEN="ADD") S IEN="" + I '$D(^DIC(+$G(FILE),0,"GL")) S OUT="Update cancelled. Invalid FILE number" Q + S OREF=^DIC(FILE,0,"GL") I '$L(OREF) S OUT="Update cancelled. Invalid file definition" Q + S CREF=$E(OREF,1,$L(OREF)-1) I $E(OREF,$L(OREF))="," S CREF=CREF_")" ; CONVERT OREF TO CREF + I IEN,'$D(@CREF@(IEN)) S OUT="Update cancelled. Invalid IEN" Q + I 'GDFLG,IEN,(DATA["-.01|"!(DATA[".01|@")) S GDFLG=1 + I GDFLG,'IEN S OUT="Deletion cancelled. Missing IEN" Q + I GDFLG D DIK(OREF,IEN) S OUT="Record deleted|"_IEN Q + S UFLG=$S($G(IEN):"E",1:"A") ; UPDATE FLAG: ADD OR EDIT + I '$L($G(DATA)) S OUT="Update cancelled. Missing/invalid data string" Q + S TOT=$L(DATA,$C(30)) I 'TOT S OUT="Update cancelled. Missing data string" Q + F CNT=1:1:TOT S DATA(CNT)=$P(DATA,$C(30),CNT) ; BUILD PRIMARY FIELD ARRAY + S %=DATA(1) I %=""!(%=$C(31)) S OUT="Update cancelled. Missing data string" Q + S %=DATA(CNT) I %[$C(31) S %=$P(%,$C(31),1),DATA(CNT)=% ; STRIP OFF END OF FILE MARKER + F CNT=1:1:TOT S X=DATA(CNT) I $L(X) D ; BUILD SECONDARY FIELD ARRAY + . S TFLG=0,DFLG=0 + . I $E(X)="+" S TFLG=1,X=$E(X,2,999),$P(FLD,U)=1 + . I $E(X)="-" S DFLG=1,X=$E(X,2,999) + . S FNO=$P(X,"|"),VAL=$P(X,"|",2) + . I '$D(^DD(FILE,+$G(FNO),0)) S:$L(OUT) OUT=OUT_"~" S OUT=OUT_FNO_"|Invalid field number" Q + . I DFLG,VAL'="" S:$L(OUT) OUT=OUT_"~" S OUT=OUT_FNO_"|Invalid deletion syntax" Q ; CANT DELETE IF A VALUE IS SENT + . I DFLG!(VAL="") S VAL="@" ; SYNC DFLG AND VAL + . I VAL="@" S DFLG=1 ; SYNC DFLG AND VAL + . S FLD(FNO)=VAL_U_TFLG_U_DFLG + . I FNO=.01,TFLG S $P(FLD,U,2)=1 ; + . Q + I $P($G(FLD(.01)),U,3),UFLG="A" S OUT="Record deletion cancelled. Missing IEN" Q ; CAN'T DELETE A RECORD WITHOUT A VALID IEN +DELREC I $P($G(FLD(.01)),U,3) D DIK(OREF,IEN) S OUT="OK" Q ; DELETE THE RECORD + I UFLG="A",'$L($P($G(FLD(.01)),U)) S OUT="Record addition cancelled. Missing .01 field" Q ; CAN'T ADD A RECORD WITHOUT A VALID .01 FIELD +ADDREC I UFLG="A" D ADD(OREF) Q ; ADD A NEW ENTRY TO A FILE +EDITREC I UFLG="E" D EDIT(OREF,IEN) Q ; EDIT AN EXISTING RECORD + Q + ; +DIK(DIK,DA) ; DELETE A RECORD + D ^DIK + D ^XBFMK + Q + ; +ADD(DIC) ; ADD A NEW ENTRY TO A FILE + N X,Y + S X=""""_$P($G(FLD(.01)),U)_"""" + S DIC(0)="L" + D ^DIC + I Y=-1 S OUT="Unable to add a new record" G AX + I $O(FLD(.01)) D EDIT(DIC,+Y) Q + S OUT="OK"_"|"_+Y +AX D ^XBFMK + Q + ; +EDIT(DIE,DA) ; EDIT AN EXISTING RECORD + N DR,RFLG,ERR,FNO,VAL,TFLG,RESULT,MSG,DIERR,DISYS + S FNO=$O(FLD(.01),-1),DR="" ;HMW Changed to include .01 in DR string + I UFLG="A" S OUT="New record added|"_DA + F S FNO=$O(FLD(FNO)) Q:'FNO S X=FLD(FNO) I $L(X) D I $G(RFLG) Q ; CHECK EA FIELD AND BUILD THE DR STRING AND ERROR STRING + . S VAL(FNO)=$P(X,U),TFLG=$P(X,U,2) I '$L(VAL(FNO)) Q + . K ERR,RESULT + . I VAL(FNO)="@"!(VAL(FNO)="") S RESULT="@" + . E D CHK^DIE(FILE,FNO,"",VAL(FNO),.RESULT,"ERR") + . I RESULT=U D Q + .. S MSG=$G(ERR("DIERR",1,"TEXT",1),"Failed FileMan data validation") + .. I $L(OUT) S OUT=OUT_"~" + .. I TFLG!GTFLG S RFLG=1,OUT=FNO_"|"_MSG Q + .. S OUT=OUT_FNO_"|"_MSG + .. Q + . S VAL(FNO)=RESULT + . I $L(DR) S DR=DR_";" + . S DR=DR_FNO_"////^S X=VAL("_FNO_")" ; BUILD DR STRING + . Q + I $G(RFLG) D:UFLG="A" DIK(DIE,DA) S OUT="Record update cancelled"_"|"_OUT G EX ; TRANSACTION ROLLBACK FLAG IS SET, ENTRY DELETED (ADD MODE) OR UPDATE CANCELLED (EDIT MODE) + L +@CREF@(DA):2 I $T D ^DIE L -@CREF@(DA) G:OUT["valid" EX S OUT="OK" S:UFLG="A" OUT=OUT_"|"_DA G EX ; SUCCESS!!!! + S OUT="Update cancelled. File locked" ; FILE LOCKED. UNABLE TO UPDATE + I $L(FLD),UFLG="A" D DIK(DIE,DA) ; ROLLBACK THE NEW RECORD +EX D ^XBFMK ; CLEANUP + Q + ; Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL.m (revision 1147) @@ -0,0 +1,406 @@ +BMXSQL ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; + Q + ; +FLDNDX(BMXGBL,BMXFL,BMXFLD) ; + ;Returns index name and set code for all indexes on field + ;on field BMXFLD in file BMXFL + S BMX31=$C(31)_$C(31) + K ^BMXTMP($J),^BMXTEMP($J) + S BMXGBL="^BMXTEMP("_$J_")" + I +BMXFL'=BMXFL D + . S BMXFL=$TR(BMXFL,"_"," ") + . I '$D(^DIC("B",BMXFL)) S BMXFL="" Q + . S BMXFL=$O(^DIC("B",BMXFL,0)) + I '$G(BMXFL) D ERROUT("File number not provided.",1) Q + ; + ;Check for field name + I +BMXFLD'=BMXFLD D + . S BMXFLD=$TR(BMXFLD,"_"," ") + . I '$D(^DD(BMXFL,"B",BMXFLD)) S BMXFLD="" Q + . S BMXFLD=$O(^DD(BMXFL,"B",BMXFLD,0)) + I '$G(BMXFLD) D ERROUT("Field not provided",1) Q + ; + ;Set up Column names + S ^BMXTEMP($J,0)="T"_$$NUMCHAR(30)_"INDEX^T"_$$NUMCHAR(200)_"CODE"_$C(30) + ; + ;Write field data to BMXTEMP + S BMXI=0,I=0 + N BMXNAM,BMXCOD,BMXNOD,BMXTYP + F S BMXI=$O(^DD(BMXFL,BMXFLD,1,BMXI)) Q:'+BMXI Q:$D(BMXERR) D + . S I=I+1 + . S BMXNOD=$G(^DD(BMXFL,BMXFLD,1,BMXI,0)) + . S BMXNAM=$P(BMXNOD,U,2) + . S BMXTYP=$P(BMXNOD,U,3) + . S:BMXTYP="" BMXTYP="REGULAR" + . S BMXCOD=$G(^DD(BMXFL,BMXFLD,1,BMXI,1)) + . S BMXCOD=$TR(BMXCOD,"^","~") + . S ^BMXTEMP($J,I)=BMXNAM_U_BMXTYP_U_BMXCOD_$C(30) + Q + ; +TLIST(BMXGBL,BMXFROM,BMXTO) ; + ;Returns list of Fileman files to which user has READ access + ;TODO: Pass in type of access (RD,DL,WR) in BMXPAR + ; + N A,F,BMXF,BMXFLD,D0,BMXU,I,BMXCNT,BMXMFL,BMXRD,BMXMAX + S U="^" + S:$G(BMXFROM)="RD" BMXFROM="" + K ^BMXTMP($J),^BMXTEMP($J) + S BMXGBL="^BMXTEMP("_$J_")" + S BMXF=1 + S BMXF("FILE")=1 + S BMXFLD("FILE")="1^.01" + S BMXFLD("NUMBER")="1^.001" ;ADDED + S BMXFLDN=$P(BMXFLD("FILE"),"^",2) + S BMXFLDN(1,BMXFLDN)="FILE" + S BMXFLDN=$P(BMXFLD("NUMBER"),"^",2) ;ADDED + S BMXFLDN(1,BMXFLDN)="NUMBER" ;ADDED + S BMXFLDO=2 ;CHANGED FROM 1 TO 2 + S BMXFLDO(0)="1^.01" + S BMXFLDOX(1,.01,"E")=0 + S BMXFLDO(1)="1^.001" ;ADDED + S BMXFLDOX(1,.001,"E")=1 ;ADDED + S BMXFNX(1)="FILE" + S BMXFO(1)="1" + S BMXU=$G(DUZ(0)) + S BMXRD=$C(30) + S ^BMXTEMP($J,0)="T00030FILE^N00010NUMBER"_BMXRD + S BMXSET="S I=I+1,^BMXTEMP($J,I)=$P($G(^DIC(D0,0)),U)_U_D0_BMXRD,BMXCNT=BMXCNT+1" + S D0=0,I=0,BMXCNT=0,BMXMAX=2000 + S BMXFROM=$G(BMXFROM),BMXTO=$G(BMXTO) + I +BMXFROM=BMXFROM D ;BMXFROM is a filenumber + . S F=(+BMXFROM-1),T=+BMXTO + . S:BMXTOT Q:BMXCNT>BMXMAX I $D(^DD(D0)) D TLIST1 + I +BMXFROM'=BMXFROM D ;F is a filename or is null + . S F="",T="zzzzzzz" + . S:$G(BMXFROM)]"" F=$O(^DIC("B",BMXFROM),-1) + . S:$G(BMXTO)]"" T=BMXTO + . F S F=$O(^DIC("B",F)) Q:F="" Q:F]T Q:BMXCNT>BMXMAX D + . . S D0=0 F S D0=$O(^DIC("B",F,D0)) Q:'+D0 D TLIST1 + ; + S I=I+1,^BMXTEMP($J,I)=$C(31) + Q + ; +TLIST1 ; + I BMXU="@" X BMXSET Q + Q:$D(^DIC(D0,0))'=11 + S A=$G(^DIC(D0,0,"RD")) + I $D(^VA(200,DUZ,"FOF",D0,0)) D Q + . ;I $P(^(0),U,5)="1" X BMXSET Q + . I $P(^VA(200,DUZ,"FOF",D0,0),U,5)="1" X BMXSET Q + F J=1:1:$L(A) I DUZ(0)[$E(A,J) X BMXSET + Q + ; +SQLCOL(BMXGBL,BMXSQL) ;EP + D INTSQL(.BMXGBL,.BMXSQL,1) + Q + ; +SQLD(BMXGBL,BMXSQL) ;EP Serenji Debug Entrypoint + ;D DEBUG^%Serenji("SQLD^BMXSQL(.BMXGBL,.BMXSQL)") + Q + ; +SQL(BMXGBL,BMXSQL) ;EP + D INTSQL(.BMXGBL,.BMXSQL,0) + Q + ; +INTSQL(BMXGBL,BMXSQL,BMXCOL) ;EP + ; + ;SQL Top Wait for debug break + ;D + ;. F J=1:1:10 S K=$H H 1 + ;. Q + ; + S X="ERRTRAP^BMXSQL",@^%ZOSF("TRAP") + I $G(BMXSQL)="" S BMXSQL="" D + . N C S C=0 F S C=$O(BMXSQL(C)) Q:'+C D + . . S BMXSQL=BMXSQL_BMXSQL(C) + ; + I BMXSQL["call SHAPE" S BMXSQL="SELECT JUNKNAME, MULTCOLOR FROM JUNKMULT" + ; Global-scope variables + K BMXTK + N BMXF,BMXTK,T,BMXFLD,BMXTMP,BMXM,BMXXMAX,BMXFLDN,BMXV + N BMXX,BMXFG,BMXFF,BMXSCR,BMXPFP + N BMXERR,BMXFLDO,BMXFLDOX,BMXFJ,BMXFO,BMXFNX + N BMXMFL,BMXFLDA + D ^XBKVAR + S U="^" + I $D(^%ZOSF("MAXSIZ")) S X=640 X ^%ZOSF("MAXSIZ") + K ^BMXTMP($J),^BMXTEMP($J),^BMXTMPD($J) + S BMXGBL="^BMXTEMP("_$J_")" + ;Remove CR and LF from BMXSQL + S BMXSQL=$TR(BMXSQL,$C(13)," ") + S BMXSQL=$TR(BMXSQL,$C(10)," ") + S BMXSQL=$TR(BMXSQL,$C(9)," ") + S BMXSQL=$TR(BMXSQL,$C(34),"") + D PARSE^BMXPRS(BMXSQL) + S BMXXMAX=1000000 ;Default Maximum records to return. + D KW^BMXSQL1(.BMXTK) + Q:$D(BMXERR) + ; + ;Get file names into BMXF("NAME")="NUMBER" + ;Get file numbers into BMXFNX(NUMBER)="NAME" + ; Files are ordered in BMXFO(order)="NUMBER" + ; +FROM S T=$G(BMXTK("FROM")) + I '+T S BMXERR="'FROM' CLAUSE NOT FOUND" D ERROR Q + S BMXF=0 + F S T=$O(BMXTK(T)) Q:'+T Q:T=$G(BMXTK("WHERE")) Q:T=$G(BMXTK("ORDER BY")) Q:T=$G(BMXTK("GROUP BY")) D Q:$D(BMXERR) + . Q:BMXTK(T)="," + . N BMXFNT + . I BMXTK(T)["'" S BMXTK(T)=$P(BMXTK(T),"'",2) + . S BMXTK(T)=$TR(BMXTK(T),"_"," ") + . I '(BMXTK(T)?.N),'$D(^DIC("B",BMXTK(T))) S BMXERR="FILE NOT FOUND" D ERROR Q + . S BMXF=BMXF+1 + . I BMXTK(T)?.N S BMXFNT=BMXTK(T) + . E S BMXFNT=$O(^DIC("B",BMXTK(T),0)) + . S BMXMFL(BMXFNT,"GLOC")=^DIC(BMXFNT,0,"GL") + . D F1(BMXF,BMXTK(T),BMXFNT) + . I '+BMXF(BMXTK(T)) S BMXERR="FILE NUMBER NOT FOUND" D ERROR Q + . D ;Test alias + . . Q:'+$O(BMXTK(T)) + . . N V + . . S V=T+1 + . . Q:$G(BMXTK(V))="," + . . Q:V=$G(BMXTK("WHERE")) + . . Q:V=$G(BMXTK("ORDER BY")) + . . Q:V=$G(BMXTK("GROUP BY")) + . . S BMXTK(T,"ALIAS")=BMXTK(V) + . . K BMXTK(V) + . . Q + . Q + ; + D SELECT^BMXSQL5 + I $D(BMXERR) G END + D POST2^BMXPRS ;Remove commas from BMXTK + D KW^BMXSQL1(.BMXTK) + ; + D WHERE^BMXSQL7 + ; + ;Find the first WHERE field that has an index + I $D(BMXERR) G END + ; + D INDEX(.BMXFF,.BMXX,.BMXTMP) + ; + S:BMXTMP BMXX=BMXTMP + ; + ;Set up screen logic for where fields + D SCREEN^BMXSQL1 + D SETX^BMXSQL2(.BMXX,.BMXFG,.BMXSCR) + ; + ; +EXEC ;Execute enumerator and screen code to call Output routine + ; + N BMXOUT,J,BMXC + S BMXOUT=0 + ;Debug lines (retain): + ;K ^HW("BMXX") S J=0 F S J=$O(BMXX(J)) Q:'+J S ^HW("BMXX",J)=BMXX(J) + ;K ^HW("BMXSCR") S ^HW("BMXSCR")=$G(BMXSCR) S J=0 F S J=$O(BMXSCR(J)) Q:'+J S ^HW("BMXSCR",J)=BMXSCR(J) + ;Test for SHOWPLAN + I $G(BMXTK("SHOWPLAN"))="TRUE" D WPLAN Q + S BMXM=0 + I 'BMXCOL S J=0 F S J=$O(BMXX(J)) Q:'+J D Q:BMXM>BMXXMAX + . X BMXX(J) + ; + D WRITE^BMXSQL6 + ; +END Q + ; + ; +F1(BMXC,BMXNAM,BMXNUM) ;EP + S BMXF(BMXNAM)=BMXNUM + S BMXFNX(BMXNUM)=BMXNAM + S BMXFO(BMXC)=BMXF(BMXNAM) + Q + ; +OUT ;Set result in ^BMXTMP + S BMXOUT=BMXOUT+1 + S ^BMXTMP($J,"O",D0)="" + S ^BMXTMP($J,BMXOUT)=D0 + S BMXM=BMXM+1 + Q + ; +WPLAN ;Write execution plan + ;Set up Column Names + N BMXLEN,BMXTYP,BMXT,J,BMXSCRT,BMXXT + S I=1 + F BMXT="VARIABLE^","VALUE"_$C(30) D + . S ^BMXTEMP($J,I)=BMXT,BMXLEN(I)=15,BMXTYP(I)="T" + . S I=I+1 + S J=0 + I $D(BMXX) F S J=$O(BMXX(J)) Q:'+J D + . S ^BMXTEMP($J,I)="INDEX("_J_")^" + . S I=I+1 + . S BMXXT(J)=BMXX(J) + . S BMXXT(J)=$P(BMXXT(J)," X BMXSCR") + . S ^BMXTEMP($J,I)=$TR(BMXXT(J),"^","~")_$C(30) + . S:$L(^BMXTEMP($J,I))>BMXLEN(2) BMXLEN(2)=$L(^BMXTEMP($J,I)) + . S I=I+1 + S ^BMXTEMP($J,I)="SCREEN^" + S I=I+1 + S BMXSCRT=$G(BMXSCR) + S BMXSCRT=$P(BMXSCRT,"D:'$D(^BMXTMP") + S ^BMXTEMP($J,I)=$TR(BMXSCRT,"^","~")_$C(30) + S:$L(^BMXTEMP($J,I))>BMXLEN(2) BMXLEN(2)=$L(^BMXTEMP($J,I)) + S I=I+1 + S J=0 + I $D(BMXSCR("C")) F S J=$O(BMXSCR("C",J)) Q:'+J D + . S ^BMXTEMP($J,I)="SCREEN("_J_")^" + . S I=I+1 + . S ^BMXTEMP($J,I)=$TR(BMXSCR("C",J),"^","~")_$C(30) + . S:$L(^BMXTEMP($J,I))>BMXLEN(2) BMXLEN(2)=$L(^BMXTEMP($J,I)) + . S I=I+1 + D COLTYPE + S I=I+1 + D ERRTACK(I) + Q + ; + ; +COLTYPE ;EP - Append column types and widths to output global + ;REQUIRES - BMXLEN(),BMXTYP(),^BMXTEMP + ;IHS/SET/HMW 4-22-2004 Modified to use new schema string + ; + ;"@@@meta@@@BMXIEN|FILE #|DA STRING" + ; + N C + S C=0 + F S C=$O(BMXLEN(C)) Q:'C D + . I BMXLEN(C)>99999 S BMXLEN(C)=99999 + . I BMXLEN(C)=0 S BMXLEN(C)=50 ;Default column length + . S ^BMXTEMP($J,C)=BMXTYP(C)_$$NUMCHAR(BMXLEN(C))_^BMXTEMP($J,C) + Q + ; + ;S ^BXTEMP($J,0)="@@@meta@@@BMXIEN|"_BMXF_"|" ;Last |-piece will be DA string + ;N C + ;S C=0 + ;F S C=$O(BMXLEN(C)) Q:'C D + ;. I BMXLEN(C)>99999 S BMXLEN(C)=99999 + ;. I BMXLEN(C)=0 S BMXLEN(C)=50 ;Default column length + ;. S ^BMXTEMP($J,C)=BMXTYP(C)_$$NUMCHAR(BMXLEN(C))_^BMXTEMP($J,C) + ;Q + ; +ERRTACK(I) ;EP + ; + S ^BMXTEMP($J,I)=$C(31) + S:$D(BMXERR) ^BMXTEMP($J,I)=^BMXTEMP($J,I)_BMXERR + Q + ; +NUMCHAR(BMXN) ;EP + ;---> Returns Field Length left-padded with 0 + ; + N BMXC + S BMXC="00000"_BMXN + Q $E(BMXC,$L(BMXC)-4,$L(BMXC)) + ; + ; +INDEX(BMXFF,BMXRET,BMXXCNT) ; + ;Returns executable enumerator on first where field with an index + ;or "" if no indexed where field + ;IN: BMXFF() + ;OUT: BMXRET() + ; BMXXCNT - size of BMXRET array + ; + N F,BMXNOD,BMXFNUM,BMXFLDNM,BMXHIT,BMXREF,BMXRNAM,BMXOP,Q,BMXGL + N BMXTMP,BMXTMPV,BMXTMPI,BMXTMPL,BMXTMPN,BMXV,BMXRNOD,BMXTMPP + S BMXXCNT=0 + S Q=$C(34) + I 'BMXFF Q + S F=0,BMXHIT=0 + ; + ;--->Search BMXFF for special case WHERE clause 1 = "0" + ; reset BMXX(1) to return no records + F F=1:1:BMXFF S BMXNOD=BMXFF(F) D Q:$D(BMXERR) Q:BMXHIT + . I ($P(BMXFF(F),"^",2,4)="1^=^0")!($P(BMXFF(F),"^",2,4)="0^=^1") S BMXRET(1)="Q ",BMXHIT=1,BMXXCNT=1 + . Q + Q:BMXHIT + ; + ;Organize the first level into AND- and OR-parts + N BMXR1,BMXR2,BMXE,BMXR3,BMXRNAM + N BMXSTOP,BMXOR + D PLEVEL^BMXSQL3(.BMXFF,.BMXR1,.BMXR2) + ; + N BMXPFF S BMXPFF=0 + S BMXR3=0 + ;Look for an AND-part with only one element. + ; If found, build an iterator on it and quit + F J=1:1:$L(BMXR2,"&") D Q:BMXHIT + . S BMXE=$P(BMXR2,"&",J) + . I +BMXE=BMXE,BMXR1(BMXE,"ELEMENTS")=1 D + . . ;Test index for element + . . F K=BMXR1(BMXE,"BEGIN"):1:BMXR1(BMXE,"END") I "(^)"'[BMXFF(K) D Q ;I'm not sure why this quit was here + . . . Q:$D(BMXFF(K,"JOIN")) + . . . S BMXPFP=K,BMXPFF=0 + . . . D XRTST^BMXSQL3(.BMXFF,K,.BMXR3,.BMXRNAM,.BMXPFP) + . . . I BMXR3 S BMXHIT=1,BMXFF(K,"INDEXED")=1 + . Q:'BMXHIT + . ;Build iterator and quit + . D BLDIT^BMXSQL3(.BMXFF,K,.BMXRNAM,.BMXOR,.BMXPFP) + . S BMXXCNT=1 + . S BMXRET(BMXXCNT)=BMXOR + . Q + Q:BMXHIT + ; + ;None of the single-element AND parts has a good index or + ; there are no single-element AND parts + ;If there are no OR-parts, then there are no good indexes so quit + I $L(BMXR2,"!")=1 Q + ; + ;Test each OR-part for a good index. + ;If an OR-part is multi-element or + ;if one OR-part doesn't have an index + ;then set up to do a table scan and quit + S BMXSTOP=0 + F J=1:1:$L(BMXR2,"!") D Q:BMXSTOP + . S BMXE=$P(BMXR2,"!",J) + . I +BMXE=BMXE D + . . I BMXR1(BMXE,"ELEMENTS")'=1 S BMXSTOP=1 Q ;Multiple elements + . . ;Test index elements + . . F K=BMXR1(BMXE,"BEGIN"):1:BMXR1(BMXE,"END") I "(^)"'[BMXFF(K) D Q + . . . S BMXPFP=K,BMXPFF=0 + . . . D XRTST^BMXSQL3(.BMXFF,K,.BMXR3,.BMXRNAM,.BMXPFP) + . . . I 'BMXR3 S BMXSTOP=1 Q + . . . S BMXFF(K,"INDEXED")=1 + . . . S BMXR1(BMXE,"XREF")=BMXRNAM + ; + ;Build iterator and quit + I BMXSTOP D Q ;One of the elements had no index + . S J=0 F S J=$O(BMXFF(J)) Q:'+J K BMXFF(J,"INDEXED") + S BMXXCNT=0 + F J=1:1:$L(BMXR2,"!") D + . S BMXE=$P(BMXR2,"!",J) + . I +BMXE=BMXE,BMXR1(BMXE,"ELEMENTS")=1 D + . . F K=BMXR1(BMXE,"BEGIN"):1:BMXR1(BMXE,"END") I "(^)"'[BMXFF(K) D Q + . . . D BLDIT^BMXSQL3(.BMXFF,K,BMXR1(BMXE,"XREF"),.BMXOR,.BMXPFP) + . . . S BMXXCNT=BMXXCNT+1 + . . . S BMXRET(BMXXCNT)=BMXOR + . Q + Q + ; + ; + ; +ERROR ;EP - Error processing + ;W !,BMXERR + ;N A + ;S A=0 + ;I $D(I) S A=I + ;D ERROUT(BMXERR,A) + ;B ;ERROR in BMXSQL + Q + ; +ERROUT(BMXERR,I) ;EP + ;---> Save next line for Error Code File if ever used. + ;---> If necessary, use I>1 to avoid overwriting valid data. + D ERRTACK(I) + Q + ; +ERRTRAP ; + ; + K ^BMXTEMP($J) + S ^BMXTEMP($J,0)="T00030M_ERROR"_$C(30) + S BMXZE=$$EC^%ZOSV + S BMXZE=$TR(BMXZE,"^","~") + S ^BMXTEMP($J,1)=BMXZE_$C(30) + S ^BMXTEMP($J,2)=$C(31) + Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL1.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL1.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL1.m (revision 1147) @@ -0,0 +1,336 @@ +BMXSQL1 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; +KW(BMXTK) ;EP + ;Identify and mark keywords in BMXTK + ;MODIFIES BMXTK + ; + N J,BMXSTOP,BMXTMP + ;Combine ORDER BY and GROUP BY into a single token + ; + S J=0 + F S J=$O(BMXTK(J)) Q:'+J D + . S BMXTMP=$$UCASE(BMXTK(J)) + . I BMXTMP="ORDER"!(BMXTMP="GROUP") D + . . I $D(BMXTK(J+1)),$$UCASE(BMXTK(J+1))="BY" D + . . . S BMXTK(J)=BMXTK(J)_" "_BMXTK(J+1) + . . . S BMXTK(J)=$$UCASE(BMXTK(J)) + . . . S BMXTK(BMXTK(J))=J + . . . K BMXTK(J+1) + . . . Q + . . Q + . Q + ; + ;Find SELECT + S J=0,BMXSTOP=0 + F S J=$O(BMXTK(J)) Q:'+J D Q:BMXSTOP + . I $$UCASE(BMXTK(J))="SELECT" D + . . S BMXTK(J)=$$UCASE(BMXTK(J)) + . . S BMXTK("SELECT")=J + . . S BMXSTOP=1 + . . Q + . Q + I '+J S BMXERR="SELECT KEYWORD NOT FOUND" Q + ; + ;DISTINCT + S BMXSTOP=0 + F S J=$O(BMXTK(J)) Q:'+J Q:$$UCASE(BMXTK(J))="FROM" D Q:BMXSTOP + . I $$UCASE(BMXTK(J))="DISTINCT" D + . . S BMXTK("DISTINCT")="TRUE" + . . K BMXTK(J) + . . S J=J-1 + . . S BMXSTOP=1 + . Q + ; + ;FROM + S BMXSTOP=0 + S J=J-1 + F S J=$O(BMXTK(J)) Q:'+J Q:$$UCASE(BMXTK(J))="WHERE" D Q:BMXSTOP + . I $$UCASE(BMXTK(J))="FROM" D + . . S BMXTK(J)=$$UCASE(BMXTK(J)) + . . S BMXTK("FROM")=J + . . S BMXSTOP=1 + . . Q + . Q + ; + I '$D(BMXTK("FROM")) S BMXERR="'FROM' KEYWORD NOT FOUND" Q + ; + ;WHERE + S BMXSTOP=0 + F S J=$O(BMXTK(J)) Q:'+J Q:BMXTK(J)="ORDER BY" Q:BMXTK(J)="GROUP BY" D Q:BMXSTOP + . I $$UCASE(BMXTK(J))="WHERE" D + . . S BMXTK(J)=$$UCASE(BMXTK(J)) + . . S BMXTK("WHERE")=J + . . S BMXSTOP=1 + . Q + ; + ;SHOWPLAN + S J=BMXTK("FROM") + S BMXSTOP=0 + F S J=$O(BMXTK(J)) Q:'+J D Q:BMXSTOP + . I $$UCASE(BMXTK(J))="SHOWPLAN" D + . . S BMXTK("SHOWPLAN")="TRUE" + . . K BMXTK(J) + . . S J=J-1 + . . S BMXSTOP=1 + . Q + ; + ;MAXRECORDS + S J=BMXTK("FROM") + S BMXSTOP=0 + F S J=$O(BMXTK(J)) Q:'+J D Q:BMXSTOP + . I $$UCASE(BMXTK(J))["MAXRECORDS" D + . . S BMXXMAX=+$P(BMXTK(J),":",2)-1 + . . S:+BMXXMAX<0 BMXXMAX=0 + . . K BMXTK(J) + . . S J=J-1 + . . S BMXSTOP=1 + . Q + Q + ; +SCREEN ;EP + ;Set up BMXFG() array of executable screen code + N F,BMXNOD,BMXFNUM,BMXFLDNM,BMXHIT,BMXREF + N BMXRNAM,BMXRET,BMXOP,Q,BMXPC,BMXV,BMXFLDLO,BMXFLDNO + N BMXGL + S BMXRET="" + S Q=$C(34) + S BMXFG=BMXFF + S BMXFG("C")=0 + I 'BMXFF Q + S F=0,BMXHIT=0 + F F=1:1:BMXFF S BMXNOD=BMXFF(F) D Q:$D(BMXERR) Q:BMXHIT + . I $G(BMXFF(F,"INDEXED"))=1 D Q + . . S BMXFG(F)="1" + . . Q + . I $D(BMXFF(F,"JOIN")) D Q + . . S BMXFG(F)="1" + . . Q + . I "(^)"[BMXFF(F) D Q + . . S BMXFG(F)=BMXFF(F) + . . Q + . I "AND^OR"[BMXFF(F) D Q + . . I BMXFF(F)="AND" S BMXFG(F)="&" Q + . . S BMXFG(F)="!" + . . Q + . S BMXFNUM=$S(+$P(BMXNOD,U):$P(BMXNOD,U),1:$O(^DIC("B",$P(BMXNOD,U),0))) + . I '+BMXFNUM D ;Not a fileman field + . . S BMXFLDNM=0,BMXFLDNO="" + . . S BMXFLDLO=$P(BMXFF(F),U,2) + . . ; + . E D ;Get fileman field data + . . S BMXGL=^DIC(BMXFNUM,0,"GL") + . . I $D(BMXFF(F,"IEN")) D + . . . S BMXFLDNM=".001" + . . . S BMXFLDNO="IEN" + . . E D + . . . S BMXFLDNM=$O(^DD(BMXFNUM,"B",$P(BMXNOD,U,2),0)) + . . . S BMXFLDNO=^DD(BMXFNUM,BMXFLDNM,0) + . I BMXFLDNO="IEN" D ;BMXIEN field + . . N BMXEXT,C S BMXEXT=0 + . . ;S BMXPC=$P(BMXFLDNO,U,4) + . . I $P(BMXFF(F),U,5)'=BMXFO(1) S BMXEXT=1 D EXP ;Extended pointer + . . S BMXFLDLO="D0" + . . I BMXEXT S BMXFG("C",C)=BMXFG("C",C)_BMXFLDLO,BMXFLDLO="BMXSCR(""X"","_C_")" + . I $P(BMXFLDNO,U,2)["D" D ;Date field + . . N BMXEXT,C S BMXEXT=0 + . . S BMXPC=$P(BMXFLDNO,U,4) + . . I $P(BMXFF(F),U,5)'=BMXFO(1) S BMXEXT=1 D EXP ;Extended pointer + . . S BMXFLDLO="$P($G("_BMXGL_"D0,"_Q_$P(BMXPC,";")_Q_")),U,"_$P(BMXPC,";",2)_")" + . . I BMXEXT S BMXFG("C",C)=BMXFG("C",C)_BMXFLDLO,BMXFLDLO="BMXSCR(""X"","_C_")" + . I $P(BMXFLDNO,U,2)["S" D ;Set field + . . N BMXEXT,C S BMXEXT=0 + . . S BMXPC=$P(BMXFLDNO,U,4) + . . I $P(BMXFF(F),U,5)'=BMXFO(1) S BMXEXT=1 D EXP ;Extended pointer + . . S BMXFLDLO="$P("_BMXGL_"D0,"_$P(BMXPC,";")_"),U,"_$P(BMXPC,";",2)_")" + . . I BMXEXT S BMXFG("C",C)=BMXFG("C",C)_BMXFLDLO,BMXFLDLO="BMXSCR(""X"","_C_")" + . ; + . I $P(BMXFLDNO,U,2)["P" D ;Pointer field + . . N C,BMXEXT + . . S BMXEXT=0 + . . I $P(BMXFF(F),U,5)'=BMXFO(1) D + . . . N R,G,BMXJN,BMXMSCR + . . . S BMXMXCR=1 ;Remove after testing. Find out if the field is from a subfile. + . . . I BMXMXCR D Q + . . . . ;Set up a screen in BMXSCR and in BMXMFL( + . . . . Q + . . . ; + . . . ;Find the node of BMXFF that has the join info + . . . S BMXEXT=1 + . . . S BMXFG("C")=BMXFG("C")+1 + . . . S C=BMXFG("C") + . . . S R=0 F S R=$O(BMXFJ("JOIN",R)) Q:'+R I R=$P(BMXFF(F),U,5) S G=BMXFJ("JOIN",R) Q + . . . S BMXJN=BMXFF(G,"JOIN") + . . . S BMXJN=$P(BMXJN,"IEN0",1)_"D0"_$P(BMXJN,"IEN0",2) + . . . S BMXJN="S X="""","_BMXFF(G,"JOIN","IEN")_"=D0 N D0 "_BMXJN_"I +D0 S X=" + . . . S BMXFG("C",C)=BMXJN + . . S BMXFLDLO=$$SCRNP(F,BMXGL,BMXFLDNM,BMXFLDNO) + . . I BMXEXT S BMXFG("C",C)=BMXFG("C",C)_BMXFLDLO,BMXFLDLO="BMXSCR(""X"","_C_")" + . I $P(BMXFLDNO,U,2)["C" D ;Computed field + . . N C + . . S BMXPC=$P(BMXFLDNO,U,5,99) + . . S BMXFG("C")=BMXFG("C")+1 + . . S C=BMXFG("C") + . . ;If computed field not in primary file, connect navigation code + . . I $P(BMXFF(F),U,5)'=BMXFO(1) D + . . . ;Find the node of BMXFF that has the join info + . . . N R,G,BMXJN + . . . S R=0 F S R=$O(BMXFJ("JOIN",R)) Q:'+R I R=$P(BMXFF(F),U,5) S G=BMXFJ("JOIN",R) Q + . . . S BMXJN=BMXFF(G,"JOIN") + . . . S BMXJN=$P(BMXJN,"IEN0",1)_"D0"_$P(BMXJN,"IEN0",2) + . . . S BMXJN="S X="""","_BMXFF(G,"JOIN","IEN")_"=D0 N D0 "_BMXJN_"I +D0 " + . . . S BMXJN=BMXJN_BMXPC + . . . S BMXFF(F,0)=$P(BMXFF(F,0),U,1,4) + . . . S $P(BMXFF(F,0),U,5)=BMXJN + . . . S BMXPC=BMXJN + . . S BMXFG("C",C)=BMXPC + . . S BMXFLDLO="BMXSCR(""X"","_C_")" + . I $P(BMXFLDNO,U,2)["N" D ;Numeric field + . . N BMXEXT,C S BMXEXT=0 + . . S BMXPC=$P(BMXFLDNO,U,4) + . . I $P(BMXFF(F),U,5)'=BMXFO(1) S BMXEXT=1 D EXP ;Extended pointer + . . S BMXFLDLO="$P("_BMXGL_"D0,"_$P(BMXPC,";")_"),U,"_$P(BMXPC,";",2)_")" + . . I BMXEXT S BMXFG("C",C)=BMXFG("C",C)_BMXFLDLO,BMXFLDLO="BMXSCR(""X"","_C_")" + . ; + . I $P(BMXFLDNO,U,2)["F" D ;Free Text field + . . N BMXEXT,C S BMXEXT=0,C=0 + . . S BMXPC=$P(BMXFLDNO,U,4) + . . I $P(BMXFF(F),U,5)'=BMXFO(1) S BMXEXT=1 D + . . . N R,G,BMXJN + . . . S BMXFG("C")=BMXFG("C")+1 + . . . S C=BMXFG("C") + . . . S R=0 F S R=$O(BMXFJ("JOIN",R)) Q:'+R I R=$P(BMXFF(F),U,5) S G=BMXFJ("JOIN",R) Q + . . . S BMXJN=BMXFF(G,"JOIN") + . . . S BMXJN=$P(BMXJN,"IEN0",1)_"D0"_$P(BMXJN,"IEN0",2) + . . . S BMXJN="S X="""","_BMXFF(G,"JOIN","IEN")_"=D0 N D0 "_BMXJN + . . . S BMXJN=BMXJN_"I +D0 S X=" + . . . S BMXFG("C",C)=BMXJN + . . . S BMXFLDLO="BMXSCR(""X"","_C_")" + . . I $P(BMXFLDNO,U,4)["E" D + . . . N BMXPC2,BMXTMP + . . . S BMXPC2=$P(BMXPC,"E",2) + . . . S BMXTMP="$E("_BMXGL_"D0,"_$P(BMXPC,";")_"),"_$P(BMXPC2,",")_","_$P(BMXPC2,",",2)_")" + . . . I BMXEXT S BMXFG("C",C)=BMXFG("C",C)_BMXTMP + . . . E S BMXFLDLO=BMXTMP + . . E D + . . . N BMXTMP + . . . S BMXTMP="$P("_BMXGL_"D0,"_$P(BMXPC,";")_"),U,"_$P(BMXPC,";",2)_")" + . . . S BMXTMP="$S($D("_BMXGL_"D0,"_$P(BMXPC,";")_")):"_BMXTMP_",1:"""")" + . . . I BMXEXT S BMXFG("C",C)=BMXFG("C",C)_BMXTMP + . . . E S BMXFLDLO=BMXTMP + . ; + . S BMXOP=$P(BMXNOD,U,3) + . S BMXV=$P(BMXFF(F),U,4) + . I "<^>^=^["[BMXOP D + . . I BMXOP=">",BMXV?.A S BMXOP="]" + . . I BMXOP="<",BMXV?.A S BMXOP="']" + . . S BMXRET="("_BMXFLDLO_BMXOP_Q_BMXV_Q_")" + . . Q + . I "<>"=BMXOP D + . . S BMXOP="'=" + . . S BMXRET="("_BMXFLDLO_BMXOP_Q_BMXV_Q_")" + . I ">="=BMXOP D + . . I BMXV="" S BMXRET="(I 1)" Q + . . I +BMXV=BMXV D Q + . . . S BMXOP="'<" + . . . S BMXRET="("_BMXFLDLO_BMXOP_Q_BMXV_Q_")" + . . S BMXV=$$DECSTR^BMXSQL2(BMXV) + . . S BMXOP="]" + . . S BMXRET="("_BMXFLDLO_BMXOP_Q_BMXV_Q_")" + . I "<="=BMXOP D + . . I BMXV="" S BMXRET="(I 0)" Q + . . I +BMXV=BMXV D Q + . . . S BMXOP="'>" + . . . S BMXRET="("_BMXFLDLO_BMXOP_Q_BMXV_Q_")" + . . S BMXV=$$INCSTR^BMXSQL2(BMXV) + . . S BMXOP="']" + . . S BMXRET="("_BMXFLDLO_BMXOP_Q_BMXV_Q_")" + . I BMXOP="BETWEEN" D + . . I +$P(BMXV,"~")'=$P(BMXV,"~") D ;BMXV a string + . . . N W,X,Y,Z + . . . S X=$P(BMXV,"~") + . . . S Y=$E(X,1,$L(X)-1) + . . . S Z=$E(X,$L(X)) + . . . S Z=$A(Z) + . . . S Z=Z-1 + . . . S Z=$C(Z) + . . . S W=Y_Z + . . . S $P(BMXV,"~")=W + . . . S BMXRET="(("_BMXFLDLO_"]"_Q_$P(BMXV,"~")_Q_")&("_BMXFLDLO_"']"_Q_$P(BMXV,"~",2)_Q_"))" + . . E D ;BMXV a number + . . . S BMXRET="(("_BMXFLDLO_"'<"_$P(BMXV,"~")_")&("_BMXFLDLO_"'>"_$P(BMXV,"~",2)_"))" + . . Q + . I BMXOP="LIKE" D + . . S BMXRET="("_BMXFLDLO_"?1"_Q_BMXV_Q_".E)" + . I BMXRET]"" D + . . S BMXFG(F)=BMXRET + . . Q + . ;TODO: Pointer fields + . ;TODO: Computed fields + . ;TODO: Sets of codes + . ;TODO: Dates + . Q + Q + ; +SCRNP(F,BMXGL,BMXFLDNU,BMXFLDNO) ; + ;Requires BMXFF() + ;Sets up expression for pointer field + N BMX,BMXCOR,BMXRET,BMXPC + S BMXPC=$P(BMXFLDNO,U,4) + S BMXCOR="$P($G("_BMXGL_"D0,"_Q_$P(BMXPC,";")_Q_")),U,"_$P(BMXPC,";",2)_")" + S BMXRET=BMXCOR + Q:$D(BMXFF(F,"INTERNAL")) BMXRET + S BMXFNUM=$P(BMXFLDNO,U,2) + S BMXFNUM=+$P(BMXFNUM,"P",2) + S BMXGL=^DIC(BMXFNUM,0,"GL") + S BMXFLDNM=".01" + S BMXFLDNO=^DD(BMXFNUM,BMXFLDNM,0) + F D:$P(BMXFLDNO,U,2)["P" Q:$P(BMXFLDNO,U,2)'["P" + . S BMXPC=$P(BMXFLDNO,U,4) + . S BMXRET="$P($G("_BMXGL_BMXRET_","_Q_$P(BMXPC,";")_Q_")),U,"_$P(BMXPC,";",2)_")" + . S BMXFNUM=$P(BMXFLDNO,U,2) + . S BMXFNUM=+$P(BMXFNUM,"P",2) + . S BMXGL=^DIC(BMXFNUM,0,"GL") + . S BMXFLDNM=".01" + . S BMXFLDNO=^DD(BMXFNUM,BMXFLDNM,0) + ;B ;SCRN2 After chain + ;I 0 D ;$P(BMXFLDNO,U,2)["D" D ;Pointer to a date + ;. Q:+$G(BMXFF(F,"INDEXED")) ;Dates converted when iterator built + ;. N BMXD,J + ;. S BMXD=$P(BMXFF(F),U,4) + ;. S %DT="T" + ;. F J=1:1:$L(BMXD,"~") D + ;. . S X=$P(BMXD,"~",J) + ;. . D ^%DT + ;. . S $P(BMXD,"~",J)=Y + ;. S $P(BMXFF(F),U,4)=BMXD + S BMXRET="$P($G("_BMXGL_BMXRET_",0)),U,1)" + S BMXRET="$S(+"_BMXCOR_":"_BMXRET_",1:"""")" + Q BMXRET + ; +CASE(BMXTK) ;EP + ;Convert keywords to uppercase + N J + S J=0 + F S J=$O(BMXTK(J)) Q:'+J D + . F K="DISTINCT","SELECT","WHERE","FROM","SHOWPLAN" D + . . I $$UCASE(BMXTK(J))=K S BMXTK(J)=$$UCASE(BMXTK(J)) + . Q + Q + ; +UCASE(X) ;EP Convert X to uppercase + F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999) + Q X + ; +EXP ;Extended pointer + N R,G,BMXJN + S BMXEXT=1 + S BMXFG("C")=BMXFG("C")+1 + S C=BMXFG("C") + S R=0 F S R=$O(BMXFJ("JOIN",R)) Q:'+R I R=$P(BMXFF(F),U,5) S G=BMXFJ("JOIN",R) Q + S BMXJN=BMXFF(G,"JOIN") + S BMXJN=$P(BMXJN,"IEN0",1)_"D0"_$P(BMXJN,"IEN0",2) + S BMXJN="S X="""","_BMXFF(G,"JOIN","IEN")_"=D0 N D0 "_BMXJN_"I +D0 S X=" + S BMXFG("C",C)=BMXJN + Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL2.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL2.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL2.m (revision 1147) @@ -0,0 +1,97 @@ +BMXSQL2 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; +FLDFILE(BMXIN) ;EP - Returns name of file containing field BMXIN + ;in the form FILE^FIELD^FILENUMBER^FIELDNUMBER + ;Based on data contained in the BMXF() array + ;BMXIN can be either an unambiguous field name or FILE.FIELDNAME + ; + N C,BMXA,BMXB,BMXRET,BMXFILN,BMXFLDN,BMXFILNA + S BMXRET="" + I BMXTMPLT D Q BMXRET + . S BMXFILNA=BMXIN + . I '$D(BMXF(BMXFILNA)) S BMXERR="FILE NOT FOUND" S BMXRET="" D ERROR^BMXSQL Q + . I BMXF(BMXFILNA)'=BMXFO(1) S BMXERR="TEMPLATES ONLY SUPPORTED ON PRIMARY FILE" D ERROR^BMXSQL Q + . S BMXRET=BMXFILNA_U_"BMXIEN"_U_BMXF(BMXFILNA)_U_".001" + ; + I BMXIN["." D Q BMXRET + . S BMXFILNA=$P(BMXIN,".") ;File Name + . I '$D(BMXF(BMXFILNA)) S BMXERR="FILE NOT FOUND" S BMXRET="" D ERROR^BMXSQL Q + . S BMXRET=BMXFILNA_U_$P(BMXIN,".",2) + . S $P(BMXRET,U,3)=BMXF(BMXFILNA) + . S BMXFLDN=0 + . I $P(BMXIN,".",2)'="",$D(^DD(BMXF(BMXFILNA),"B",$P(BMXIN,".",2))) D + . . S BMXFLDN=$O(^DD(BMXF(BMXFILNA),"B",$P(BMXIN,".",2),0)) + . I BMXIN["BMXIEN" S BMXFLDN=".001" + . I '+BMXFLDN S BMXERR="FIELD NOT FOUND",BMXRET="" D ERROR^BMXSQL Q + . S $P(BMXRET,U,4)=BMXFLDN + . Q + ;Loop through files in BMXF to locate field name + S C=0,BMXA="" + I 'BMXIEN F S BMXA=$O(BMXF(BMXA)) Q:BMXA="" D Q:$D(BMXERR) + . I $D(^DD(BMXF(BMXA),"B",BMXIN)) S BMXRET=BMXA_U_BMXIN D Q:$D(BMXERR) + . . S C=C+1 + . . I C>1 S BMXERR="AMBIGUOUS FIELD NAME" D ERROR^BMXSQL Q + . . Q + . Q + I BMXIEN D + . S BMXA=BMXFO(1) + . S BMXA=BMXFNX(BMXA) + . S BMXRET=BMXA_U_BMXIN + . S C=1 + I C=0 D Q BMXRET + . S BMXRET="0^"_BMXIN ;String or numeric literal + S BMXFILNA=$P(BMXRET,U) + S BMXFILN=BMXF(BMXFILNA) + S $P(BMXRET,U,3)=BMXFILN + I $D(^DD(BMXFILN,"B",BMXIN)) D + . S BMXFLDN=$O(^DD(BMXFILN,"B",BMXIN,0)) + I BMXIEN S BMXFLDN=".001" + I '+BMXFLDN S BMXERR="FIELD NOT FOUND",BMXRET="" D ERROR^BMXSQL Q + S $P(BMXRET,U,4)=BMXFLDN + Q BMXRET + ; +DECSTR(BMXSTR) ;EP + ;Decrements string collation value by 1 + ; + N A,E,S,L,BMXRET + I BMXSTR="" Q BMXSTR + S L=$L(BMXSTR) + S E=$E(BMXSTR,L) + S B=$E(BMXSTR,1,L-1) + S A=$A(E) + S A=A-1 + S E=$C(A) + S BMXRET=B_E + Q BMXRET + ; +INCSTR(BMXSTR) ;EP + ;Increments string collation value by 1 + Q BMXSTR_$C(1) + ; +SETX(BMXX,BMXFG,BMXSCR) ;EP + ;Set up executable screen code + ;by assembling pieces in BMXFG + ;and attach to executable iterator(s) + ; + ;IN: BMXFG() + ; BMXX() -- modified + ;OUT: BMXSCR + ; + N J + Q:'$D(BMXFG) + S BMXSCR="" + S J=0 F S J=$O(BMXX(J)) Q:'+J D + . S BMXX(J)=BMXX(J)_"X BMXSCR" + F J=1:1:BMXFG S BMXSCR=BMXSCR_BMXFG(J) + S BMXSCR=$S(BMXSCR]"":"I "_BMXSCR_" ",1:"") + S BMXSCR=BMXSCR_"D:'$D(^BMXTMP($J,""O"",D0)) OUT^BMXSQL" + I BMXFG("C") D + . N C + . S C=BMXFG("C") + . S BMXSCR("C")="F BMXC=1:1:"_C_" X BMXSCR(""C"",BMXC) S BMXSCR(""X"",BMXC)=X" + . F C=1:1:BMXFG("C") S BMXSCR("C",C)=BMXFG("C",C) + . S BMXSCR="X BMXSCR(""C"") "_BMXSCR + ; + Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL3.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL3.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL3.m (revision 1147) @@ -0,0 +1,330 @@ +BMXSQL3 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; +PLEVEL(BMXFF,BMXLVL,BMXRET) ;EP + ;Analyze WHERE statement according to paren level + ;Return a string to guide building of iterator(s) + ; + ;Basically, count the number of OR clauses on the + ;same paren level + ;IN: BMXFF() + ;OUT: BMXLVL(), BMXRET + ; + ;BMXRET = 1&/!2&/!...&/!n clauses + ;BMXLVL(E,"BEGIN")=Index where element E begins + ;BMXLVL(E,"END") =Index where element E ends + ;BMXLVL(E,"ELEMENTS")=Number of subelements in element E + ; + N BMXNOR,BMXNAND,J,C,BMXTMP + N E,L,BMXCNT + ;Test for no ORs or no ANDs + S BMXNOR=1,BMXNAND=1 + S J=0 F S J=$O(BMXFF(J)) Q:'+J D ;Q:'BMXNOR Q:'BMXNAND + . I BMXFF(J)="OR" S BMXNOR=0 + . I BMXFF(J)="AND" S BMXNAND=0 + . Q + ;If no ORs or no ANDs then take all parens out of BMXFF + I ((BMXNOR)!(BMXNAND)) D + . S:$D(BMXFF("INDEX")) BMXTMP("INDEX")=BMXFF("INDEX") + . S J=0,C=0 F S J=$O(BMXFF(J)) Q:'+J D:"(^)"'[BMXFF(J) + . . S C=C+1 + . . S BMXTMP(C)=BMXFF(J) + . . S:$D(BMXFF(J,0)) BMXTMP(C,0)=BMXFF(J,0) + . . S:$D(BMXFF(J,"INTERNAL")) BMXTMP(J,"INTERNAL")=BMXFF(J,"INTERNAL") + . . S:$D(BMXFF(J,"TYPE")) BMXTMP(C,"TYPE")=BMXFF(J,"TYPE") + . . S:$D(BMXFF(J,"IEN")) BMXTMP(C,"IEN")=BMXFF(J,"IEN") + . . S:$D(BMXFF(J,"JOIN")) BMXTMP(C,"JOIN")=BMXFF(J,"JOIN") + . . S:$D(BMXFF(J,"JOIN","IEN")) BMXTMP(C,"JOIN","IEN")=BMXFF(J,"JOIN","IEN") + . . ;I $D(BMXFF(J,"JOIN")) D + . . ;. N K S K=0 F S K=$O(BMXFF(J,"JOIN",K)) Q:'+K D + . . ;. . N L S L=0 F S L=$O(BMXFF(J,"JOIN",K,L)) Q:'+L D + . . ;. . . S BMXTMP(C,"JOIN",K,L)=BMXFF(J,"JOIN",K,L) + . . I $D(BMXFF(J,"SET")) D + . . . N BMXSS + . . . S BMXSS="" F S BMXSS=$O(BMXFF(J,"SET",BMXSS)) Q:BMXSS="" D + . . . . S BMXTMP(C,"SET",BMXSS)=BMXFF(J,"SET",BMXSS) + . K BMXFF + . I $D(BMXTMP("INDEX")) S BMXFF("INDEX")=BMXTMP("INDEX") + . S J=0 F S J=$O(BMXTMP(J)) Q:'+J D + . . S BMXFF(J)=BMXTMP(J) + . . S:$D(BMXTMP(J,0)) BMXFF(J,0)=BMXTMP(J,0) + . . S:$D(BMXTMP(J,"TYPE")) BMXFF(J,"TYPE")=BMXTMP(J,"TYPE") + . . I $D(BMXTMP(J,"JOIN")) S BMXFF(J,"JOIN")=BMXTMP(J,"JOIN") S:$D(BMXTMP(J,"JOIN","IEN")) BMXFF(J,"JOIN","IEN")=BMXTMP(J,"JOIN","IEN") S BMXFJ("JOIN",+$P($P(BMXFF(J,0),U,2),"P",2))=J + . . ;I $D(BMXTMP(J,"JOIN")) D + . . ;. N K S K=0 F S K=$O(BMXTMP(J,"JOIN",K)) Q:'+K D + . . ;. . N L S L=0 F S L=$O(BMXTMP(J,"JOIN",K,L)) Q:'+L D + . . ;. . . S BMXFF(J,"JOIN",K,L)=BMXTMP(J,"JOIN",K,L) + . . I $D(BMXTMP(J,"SET")) D + . . . N BMXSS + . . . S BMXSS="" F S BMXSS=$O(BMXTMP(J,"SET",BMXSS)) Q:BMXSS="" D + . . . . S BMXFF(J,"SET",BMXSS)=BMXTMP(J,"SET",BMXSS) + . . I $D(BMXTMP(J,"INTERNAL")) S BMXFF(J,"INTERNAL")=BMXTMP(J,"INTERNAL") + . . I $D(BMXTMP(J,"IEN")) S BMXFF(J,"IEN")=BMXTMP(J,"IEN") + . S BMXFF=C + . Q + ; + ;Remove excess leading and trailing parens + ;Find close paren corresponding to BMXFF(1) + ;If its the last paren, then remove the first and last parens + ;Else, quit + N BMXEND + S BMXEND=0 + F Q:'((BMXFF(1)="(")&(BMXFF(BMXFF)=")")) Q:BMXEND D + . S L=1,J=1 + . F S J=$O(BMXFF(J)) Q:'+J D:"(^)"[BMXFF(J) Q:BMXEND + . . I BMXFF(J)="(" S L=L+1 Q + . . I BMXFF(J)=")" S L=L-1 + . . I L=0,J0 D Q + . . . S BMXPFF(BMXPFF,1)=BMXREF + . . . S $P(BMXPFF(BMXPFF,1),U,2)=BMXRNAM + . . . S BMXPFP(BMXPFP,BMXPFF,1)=BMXREF + . . . S $P(BMXPFP(BMXPFP,BMXPFF,1),U,2)=BMXRNAM + . . Q + . Q + Q + ; + ; +BLDIT(BMXFF,F,BMXRNAM,BMXRET,BMXPFP) ;EP - Build iterator + ; + K BMXRET + N BMXNOD,BMXOP,BMXV,BMXGL,Q + S BMXNOD=BMXFF(F) + S BMXOP=$P(BMXNOD,U,3) + S BMXV=$P(BMXNOD,U,4) + S BMXGL=$P(BMXNOD,U,7,8) + S Q=$C(34) + I $D(BMXPFP(F)) D BLDIT2 Q ;Pointer + ;TODO Set BMXV to the pointer or set or FM date that corresponds + ; to the user-entered value + I $D(BMXFF(F,"IEN")),BMXFF(F,"IEN")="TEMPLATE" D Q + . N BMXTNUM + . S BMXTNUM=$O(^DIBT("B",$P(BMXFF(F),U,4),0)) + . S BMXRET="S D0=0 F S D0=$O(^DIBT("_BMXTNUM_",1,D0)) Q:'+D0 Q:BMXM>BMXXMAX " + . Q + I BMXOP="=" D Q + . I $D(BMXFF(F,"IEN")) S BMXRET="S D0="_BMXV_" Q:'+D0 Q:BMXM>BMXXMAX " Q + . S BMXRET="S D0="""" F S D0=$O("_BMXGL_Q_BMXRNAM_Q_","_Q_BMXV_Q_",D0)) Q:D0="""" Q:BMXM>BMXXMAX " + . Q + ; + I BMXOP=">=" D Q + . I $D(BMXFF(F,"IEN")) S BMXV=BMXV-1,BMXRET="S D0="_BMXV_" F S D0=$O("_BMXGL_"D0)) Q:'+D0 Q:BMXM>BMXXMAX " Q + . N BMXTMP + . S BMXTMP="BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1)" + . S @BMXTMP + . S BMXRET="S BMXV="_Q_BMXV_Q_" F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV)) Q:BMXV="""" Q:BMXM>BMXXMAX S D0="""" F S D0=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D0)) Q:D0="""" Q:BMXM>BMXXMAX " + ; + I BMXOP=">" D Q + . I $D(BMXFF(F,"IEN")) S BMXRET="S D0="_BMXV_" F S D0=$O("_BMXGL_"D0)) Q:'+D0 Q:BMXM>BMXXMAX " Q + . S BMXRET="S BMXV="_Q_BMXV_Q_" F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV)) Q:BMXV="""" Q:BMXM>BMXXMAX S D0="""" F S D0=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D0)) Q:D0="""" Q:BMXM>BMXXMAX " + ; + I BMXOP="<>" D Q + . I $D(BMXFF(F,"IEN")) S BMXRET="S D0=0 F S D0=$O("_BMXGL_"D0)) Q:'+D0 I D0'="_BMXV_" Q:BMXM>BMXXMAX " Q + . S BMXRET="S BMXV=0 F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV)) Q:BMXV="""" Q:BMXM>BMXXMAX I BMXV'="_Q_BMXV_Q_" S D0="""" F S D0=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D0)) Q:D0="""" Q:BMXM>BMXXMAX " + ; + I BMXOP="<=" D Q + . I $D(BMXFF(F,"IEN")) S BMXRET="S D0=0 F S D0=$O("_BMXGL_"D0)) Q:'+D0 Q:D0>"_BMXV_" Q:BMXM>BMXXMAX " Q + . N BMXTMP + . S BMXTMP="BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV))" + . S @BMXTMP + . S BMXRET="S BMXV="_Q_BMXV_Q_" F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1) Q:BMXV="""" Q:BMXM>BMXXMAX S D0="""" F S D0=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D0)) Q:D0="""" Q:BMXM>BMXXMAX " + ; + I BMXOP="<" D Q + . I $D(BMXFF(F,"IEN")) S BMXRET="S D0=0 F S D0=$O("_BMXGL_"D0)) Q:'+D0 Q:D0'<"_BMXV_" Q:BMXM>BMXXMAX " Q + . S BMXRET="S BMXV="_Q_BMXV_Q_" F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1) Q:BMXV="""" Q:BMXM>BMXXMAX S D0="""" F S D0=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D0)) Q:D0="""" Q:BMXM>BMXXMAX " + ; + I BMXOP="BETWEEN" D Q ;changed '< to > (inclusive BETWEEN) + . I $D(BMXFF(F,"IEN")) D Q + . . S BMXRET="S D0="_(+$P(BMXV,"~")-1)_" F S D0=$O("_BMXGL_"D0)) Q:'+D0 Q:D0>"_$P(BMXV,"~",2)_" Q:BMXM>BMXXMAX " + . I +$P(BMXV,"~")=$P(BMXV,"~") D ;BMXV is a number + . . S BMXRET="S BMXV="_$P(BMXV,"~")_",BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1) F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q + . . S BMXRET=BMXRET_",BMXV)) Q:BMXV="""" Q:BMXV>"_$P(BMXV,"~",2)_" Q:BMXM>BMXXMAX S D0="""" F S D0=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D0)) Q:D0="""" Q:BMXM>BMXXMAX " + . E D ;BMXV is a string + . . S BMXRET="S BMXV="_Q_$P(BMXV,"~")_Q_",BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1) F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q + . . S BMXRET=BMXRET_",BMXV)) Q:BMXV="""" Q:BMXV]"_Q_$P(BMXV,"~",2)_Q_" Q:BMXM>BMXXMAX S D0="""" F S D0=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D0)) Q:D0="""" Q:BMXM>BMXXMAX " + ; + I BMXOP="LIKE" D Q + . N BMXTMP,BMXV1 + . S BMXV1=BMXV + . S BMXTMP="BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1)" + . S @BMXTMP + . S BMXRET="S BMXV="_Q_BMXV_Q_" F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV)) Q:BMXV="""" Q:BMXV'?1"_Q_BMXV1_Q_".E Q:BMXM>BMXXMAX S D0="""" F S D0=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D0)) Q:D0="""" Q:BMXM>BMXXMAX " + Q + ; +BLDIT2 ;Pointer + N BMXPS,J + S BMXPS=$O(BMXPFP(F,999),-1) + S BMXNOD=BMXPFP(F,BMXPS) + S BMXGL=$P(BMXNOD,U,7,8) + I BMXOP="=" D + . S BMXRNAM=$P(BMXPFP(F,BMXPS,1),U,2) + . S BMXRET="S D"_BMXPS_"="""" F S D"_BMXPS_"=$O("_BMXGL_Q_BMXRNAM_Q_","_Q_BMXV_Q_",D"_BMXPS_")) Q:'+D"_BMXPS_" Q:BMXM>BMXXMAX " + ; + I BMXOP=">" D + . S BMXRNAM=$P(BMXPFP(F,BMXPS,1),U,2) + . S BMXRET="S BMXV="_Q_BMXV_Q_" F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV)) Q:BMXV="""" Q:BMXM>BMXXMAX S D"_BMXPS_"="""" F S D"_BMXPS_"=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D"_BMXPS_")) Q:'+D"_BMXPS_" Q:BMXM>BMXXMAX " + ; + I BMXOP=">=" D + . N BMXTMP + . S BMXRNAM=$P(BMXPFP(F,BMXPS,1),U,2) + . S BMXTMP="BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1)" + . S @BMXTMP + . S BMXRET="S BMXV="_Q_BMXV_Q_" F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV)) Q:BMXV="""" Q:BMXM>BMXXMAX S D"_BMXPS_"="""" F S D"_BMXPS_"=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D"_BMXPS_")) Q:'+D"_BMXPS_" Q:BMXM>BMXXMAX " + ; + I BMXOP="<=" D + . N BMXTMP + . S BMXRNAM=$P(BMXPFP(F,BMXPS,1),U,2) + . S BMXTMP="BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV))" + . S @BMXTMP + . S BMXRET="S BMXV="_Q_BMXV_Q_" F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1) Q:BMXV="""" Q:BMXM>BMXXMAX S D"_BMXPS_"="""" F S D"_BMXPS_"=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D"_BMXPS_")) Q:'+D"_BMXPS_" Q:BMXM>BMXXMAX " + ; + I BMXOP="<>" D + . S BMXRNAM=$P(BMXPFP(F,BMXPS,1),U,2) + . S BMXRET="S BMXV=0 F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV)) Q:BMXV="""" Q:BMXM>BMXXMAX I BMXV'="_Q_BMXV_Q_" S D"_BMXPS_"="""" F S D"_BMXPS_"=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D"_BMXPS_")) Q:'+D"_BMXPS_" Q:BMXM>BMXXMAX " + ; + I BMXOP="<" D + . S BMXRNAM=$P(BMXPFP(F,BMXPS,1),U,2) + . S BMXRET="S BMXV="_Q_BMXV_Q_" F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1) Q:BMXV="""" Q:BMXM>BMXXMAX S D"_BMXPS_"="""" F S D"_BMXPS_"=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D"_BMXPS_")) Q:'+D"_BMXPS_" Q:BMXM>BMXXMAX " + ; + I BMXOP="BETWEEN" D + . S BMXRNAM=$P(BMXPFP(F,BMXPS,1),U,2) + . I +$P(BMXV,"~")=$P(BMXV,"~") D ;BMXV is a number + . . S BMXRET="S BMXV="_$P(BMXV,"~")_",BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1) F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q + . . S BMXRET=BMXRET_",BMXV)) Q:BMXV="""" Q:BMXV>"_$P(BMXV,"~",2)_" Q:BMXM>BMXXMAX S D"_BMXPS_"=0 F S D"_BMXPS_"=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D"_BMXPS_")) Q:'+D"_BMXPS_" Q:BMXM>BMXXMAX " + . E D ;BMXV is a string + . . S BMXRET="S BMXV="_Q_$P(BMXV,"~")_Q_",BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1) F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q + . . S BMXRET=BMXRET_",BMXV)) Q:BMXV="""" Q:BMXV]"_Q_$P(BMXV,"~",2)_Q_" Q:BMXM>BMXXMAX S D"_BMXPS_"=0 F S D"_BMXPS_"=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D"_BMXPS_")) Q:'+D"_BMXPS_" Q:BMXM>BMXXMAX " + ; + I BMXOP="LIKE" D + . N BMXTMP,BMXV1 + . S BMXRNAM=$P(BMXPFP(F,BMXPS,1),U,2) + . S BMXV1=BMXV + . S BMXTMP="BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV),-1)" + . S @BMXTMP + . S BMXRET="S BMXV="_Q_BMXV_Q_" F S BMXV=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV)) Q:BMXV="""" Q:BMXV'?1"_Q_BMXV1_Q_".E Q:BMXM>BMXXMAX S D"_BMXPS_"="""" F S D"_BMXPS_"=$O("_BMXGL_Q_BMXRNAM_Q_",BMXV,D"_BMXPS_")) Q:'+D"_BMXPS_" Q:BMXM>BMXXMAX " + ; + F J=BMXPS-1:-1:0 D + . S BMXNOD=BMXPFP(F,J) + . S BMXGL=$P(BMXNOD,U,7,8) + . S BMXRNAM=$P(BMXPFP(F,J,1),U,2) + . S BMXRET=BMXRET_"S D"_J_"=0 F S D"_J_"=$O("_BMXGL_Q_BMXRNAM_Q_",D"_(J+1)_",D"_J_")) Q:'+D"_J_" Q:BMXM>BMXXMAX " + Q + ;TODO: Computed fields + ;TODO: Sets of codes + ;TODO: User-specified index + Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL4.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL4.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL4.m (revision 1147) @@ -0,0 +1,33 @@ +BMXSQL4 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; +JOIN ;EP - Join processing + ;Create a pointer chain back to the primary file + ;or to a reverse pointer file, E.G.: + ;Either executable code or an expression that returns the + ;IEN of the terminal pointed-to file + ; + ; S IEN1=$P(^DIZ(1000,IEN2,0),U,4) + ; I +IEN1 S IEN=$P(^AUTTLOC(IEN1,0),U,23) + ; + Q:'$D(BMXFJ("JOIN")) + N C,D,E,BMXSTOP,BMXPTF,BMXPTG,BMXPTL,BMXPTN,BMXPTP,BMXPTC + S C=0 F S C=$O(BMXFF(C)) Q:'+C D + . Q:'$D(BMXFF(C,"JOIN")) + . S BMXPTL=1,BMXPTC="",D=C ;Pointer level + . F S BMXPTF=$P(BMXFF(D),U,5) D Q:BMXPTF=BMXFO(1) + . . S BMXPTG=$P(BMXFF(D),U,7,99) ;Pf Global + . . S BMXPTN=$P(BMXFF(D,0),U,4) ;Pf Node + . . S BMXPTP=$P(BMXPTN,";",2) ;Pf Piece + . . S BMXPTN=$P(BMXPTN,";") + . . S BMXPTC="I +IEN"_BMXPTL_" S IEN"_(BMXPTL-1)_"=$P($G("_BMXPTG_"IEN"_BMXPTL_","_BMXPTN_")),U,"_BMXPTP_") "_BMXPTC + . . S BMXPTL=BMXPTL+1 + . . ;S D To the index of the pointed to file's entry in BMXFF + . . Q:BMXPTF=BMXFO(1) + . . S E=0,BMXSTOP=0 F S E=$O(BMXFF(E)) Q:'+E Q:BMXSTOP D + . . . I $D(BMXFF(E,0)),+$P($P(BMXFF(E,0),U,2),"P",2)=BMXPTF S D=E,BMXSTOP=1 Q + . . . I $D(BMXFF(E,0)),BMXPTF=9000001,+$P($P(BMXFF(E,0),U,2),"P",2)=2 S D=E,BMXSTOP=1 Q ;IHS auto join PATIENT to VA PATIENT + . S BMXFF(C,"JOIN")=BMXPTC + . S BMXFF(C,"JOIN","IEN")="IEN"_(BMXPTL-1) + Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL5.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL5.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL5.m (revision 1147) @@ -0,0 +1,181 @@ +BMXSQL5 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; +SELECT ;EP - Get field names into BMXFLD("NAME")="FILE#^FIELD#" + N BMXA,BMXB,BMXS,BMXSINGL + N BMXINTNL + S T=$G(BMXTK("SELECT")) + I '+T S BMXERR="'SELECT' CLAUSE NOT FOUND" D ERRTACK^BMXSQL(1) Q + S BMXFLD=0 + N BMXOFF,BMXGS1,BMXLVL + F S T=$O(BMXTK(T)) Q:'+T Q:T=$G(BMXTK("FROM")) I BMXTK(T)'="," S BMXOFF=1,BMXLVL=0 D S1 Q:$D(BMXERR) + Q + ; +SALIAS ; + Q:'+$O(BMXTK(T)) + N V + S V=T+1 + Q:$G(BMXTK(V))="," + Q:V=$G(BMXTK("FROM")) + S:BMXTK(V)["'" BMXTK(V)=$P(BMXTK(V),"'",2) + S BMXFLDA(BMXFILE,BMXFLDN)=BMXTK(V) + S $P(BMXFLDO(BMXFLDO-1),U,6)=BMXTK(V) + S T=T+1 + Q + ; +S1 ; + S BMXTK(T)=$TR(BMXTK(T),"_"," ") + ;Check for INTERNAL[ modifier + S BMXGS1=0 + S BMXINTNL="E" + I BMXTK(T)["[" S BMXINTNL="I",BMXTK(T)=$P(BMXTK(T),"[",2),BMXTK(T)=$P(BMXTK(T),"]",1) + ;If explicit file name + S BMXSINGL=0 + I BMXTK(T)["." D G:BMXGS1 S1 G:BMXSINGL NOTEXP Q + . ;Before FILE.FIELD Parsing + . S BMXA=$P(BMXTK(T),".",1,BMXOFF) ;File Name + . I '$D(BMXF(BMXA)) D Q:$D(BMXERR) Q:BMXSINGL + . . I $D(^DD(BMXFO(1),"B",BMXTK(T))),BMXOFF=1 S BMXSINGL=1 Q + . . S BMXERR="FILE NOT FOUND" D ERRTACK^BMXSQL(1) Q + . S BMXB=$P(BMXTK(T),".",1+BMXOFF,99) ;Field Name TODO: Test here for multiple in extended pointer -- FILE.MULTIPLE.FIELD + . N BMXLAST S BMXLAST=0 + . I $L(BMXB,".")>1 D Q:'BMXLAST ;Multiple + . . N BMXFNUM,BMXFNAM,BMXFNOD,BMXSUBFN,BMXUPFN,BMXGL,W,BMXFOUND + . . ;Multiple or Field-name with period? + . . S BMXFOUND=0 + . . F W=1:1:$L(BMXTK(T),".") D Q:BMXFOUND + . . . S BMXOFF=BMXOFF+1 + . . . I $D(^DD(BMXF(BMXA),"B",$P(BMXB,".",1,W))) D + . . . . S BMXFNAM=$P(BMXB,".",1,W) + . . . . S BMXFOUND=1 + . . . . S:W=$L(BMXB,".") BMXLAST=1 + . . . . S BMXLVL=BMXLVL+1 + . . ; + . . Q:BMXLAST + . . S BMXF=BMXF+1 + . . S BMXFNUM=$O(^DD(BMXF(BMXA),"B",BMXFNAM,0)) ;FieldNumber + . . S BMXFNOD=^DD(BMXF(BMXA),BMXFNUM,0) + . . S BMXGL=$P(BMXFNOD,U,4),BMXGL=$P(BMXGL,";") + . . S BMXSUBFN=+$P(BMXFNOD,U,2) ;Subfile Number + . . S BMXUPFN=^DD(BMXSUBFN,0,"UP") ;Parent File Number + . . D SETMFL(BMXUPFN,BMXSUBFN,BMXGL,BMXLVL,0) + . . S BMXGS1=1 + . S:BMXB["'" BMXB=$P(BMXB,"'",2) + . I BMXB="BMXIEN" D Q + . . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA) + . . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=".001" + . . D SELECT1 + . I BMXB="*" D Q ;All fields in file BMXA + . . ;BMXIEN Has to be first because ADO doesn't handle it well if a DATE type column is returned first + . . S BMXB="BMXIEN" + . . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA) + . . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=".001" + . . D SELECT1 + . . S BMXB=0 F S BMXB=$O(^DD(BMXF(BMXA),"B",BMXB)) Q:BMXB="" D + . . . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA) + . . . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=$O(^DD(BMXF(BMXA),"B",BMXB,0)) + . . . D SELECT1 + . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA) + . I '$D(^DD(BMXF(BMXA),"B",BMXB)) S BMXERR="FIELD NOT FOUND" D ERRTACK^BMXSQL(1) Q + . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=$O(^DD(BMXF(BMXA),"B",BMXB,0)) + . D SELECT1 + . Q + ; +NOTEXP ;File not explicit so Loop through files in BMXF to locate field name + ; + I BMXTK(T)["'" S BMXTK(T)=$P(BMXTK(T),"'",2) + S C=0,BMXA="" + I BMXTK(T)="BMXIEN" D Q + . S BMXB=BMXTK(T) + . S BMXA=BMXFO(1) ;File defaults to first named file in FROM + . S BMXA=BMXFNX(BMXA) + . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA) + . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=".001" + . D SELECT1 + F S BMXA=$O(BMXF(BMXA)) Q:BMXA="" D Q:$D(BMXERR) + . S BMXB=BMXTK(T) + . I BMXB="*" D Q ;All fields in file BMXA + . . S BMXB="BMXIEN" + . . S BMXA=BMXFO(1) ;File defaults to first named file in FROM + . . S BMXA=BMXFNX(BMXA) + . . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA) + . . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=".001" + . . D SELECT1 + . . S BMXB=0 F S BMXB=$O(^DD(BMXF(BMXA),"B",BMXB)) Q:BMXB="" D + . . . S BMXS=BMXA_"."_BMXB + . . . S BMXFLD(BMXS)=BMXF(BMXA) + . . . S $P(BMXFLD(BMXS),"^",2)=$O(^DD(BMXF(BMXA),"B",BMXB,0)) + . . . D SELECT1 + . . . S C=1 + . I $D(^DD(BMXF(BMXA),"B",BMXTK(T))) D Q:$D(BMXERR) + . . S C=C+1 + . . I C>1 S BMXERR="AMBIGUOUS FIELD NAME" D ERRTACK^BMXSQL(1) Q + . . S BMXB=BMXTK(T) ;Field Name + . . I BMXB["'" S BMXB=$P(BMXB,"'",2) + . . S BMXFLD(BMXA_"."_BMXB)=BMXF(BMXA) + . . S $P(BMXFLD(BMXA_"."_BMXB),"^",2)=$O(^DD(BMXF(BMXA),"B",BMXB,0)) + . . D SELECT1 + . . Q + . Q + I C=0 S BMXERR="FIELD NOT FOUND" D ERRTACK^BMXSQL(1) Q + Q + ; +SELECT1 ; + N BMXGNOD,BMXFILE,BMXGNOD1 + S BMXFLDN=$P(BMXFLD(BMXA_"."_BMXB),"^",2) + S BMXFILE=$P(BMXFLD(BMXA_"."_BMXB),U) + S BMXFLDN(BMXFILE,BMXFLDN)=BMXB + I BMXFLDN=".001" S BMXGNOD="IEN",BMXGNOD1="",$P(BMXGNOD1,U,2)="N" + E S BMXGNOD1=^DD(BMXFILE,BMXFLDN,0) + S BMXGNOD=$P(BMXGNOD1,"^",4) + S $P(BMXFLD(BMXA_"."_BMXB),"^",3)=$P(BMXGNOD,";") + S $P(BMXFLD(BMXA_"."_BMXB),"^",4)=$P(BMXGNOD,";",2) + S $P(BMXFLD(BMXA_"."_BMXB),"^",5)=BMXINTNL + S BMXFLDO(BMXFLD)=BMXFILE_"^"_BMXFLDN_"^"_BMXINTNL + I +$P(BMXGNOD1,U,2) D ;Check for WP + . S BMXGNOD1=+$P(BMXGNOD1,U,2) + . Q:'$D(^DD(BMXGNOD1,.01,0)) + . I $P(^DD(BMXGNOD1,.01,0),U,2)["W" S $P(BMXFLDO(BMXFLD),U,4)="W" + ;HMW20030630 Modified next line to make data type of Internal[] for pointer an Integer. + I $P(BMXGNOD1,U,2)["P" S BMXGNOD1=$$PTYPE(BMXGNOD1) Q:BMXGNOD1="" S:$G(BMXINTNL)="I" $P(BMXGNOD1,U,2)="N" ;I BMXGNOD1="" then Pointed-to file doesn't exist + I $P(BMXGNOD1,U,2)["D" S $P(BMXFLDO(BMXFLD),U,5)="D" + I $P(BMXGNOD1,U,2)["N" D + . N Z + . S Z=$P(BMXGNOD1,U,2) + . I +$P(Z,",",2)=0 S $P(BMXFLDO(BMXFLD),U,5)="I" ;Integer + S BMXFLDOX(BMXFILE,BMXFLDN,BMXINTNL)=BMXFLD + S BMXFLD=BMXFLD+1 + S BMXFLDO=BMXFLD + D SALIAS + Q + ; +SETMFL(BMXUPFN,BMXSUBFN,BMXGL,BMXOFF,BMXOTM) ;EP + ; + ;BMXOTM = One-To-Many + N BMXUPG + S BMXMFL("PARENT",BMXSUBFN)=BMXUPFN + S BMXMFL(BMXUPFN,"SUBFILE",BMXSUBFN)="" + S BMXMFL("SUBFILE",BMXUPFN,BMXSUBFN)="" + S BMXUPG=BMXMFL(BMXUPFN,"GLOC") ;Parent File Global Set in FROM clause + S BMXFNAM=BMXA_"."_BMXFNAM ;TODO: Regression test this line with OTM + I 'BMXOTM S BMXMFL(BMXSUBFN,"GLOC")=BMXUPG_"IEN"_(BMXOFF-1)_","_$C(34)_BMXGL_$C(34)_"," + E S BMXMFL(BMXSUBFN,"GLOC")=BMXGL,BMXMFL(BMXSUBFN,"OTM")="" + S BMXMFL(BMXSUBFN,"MULT")="S IEN"_BMXOFF_"=0 F S IEN"_BMXOFF_"=$O("_BMXMFL(BMXSUBFN,"GLOC")_"IEN"_BMXOFF_")) Q:'+IEN"_BMXOFF_" " + I $D(BMXMFL(BMXUPFN,"MULT")) S BMXMFL(BMXSUBFN,"MULT")=BMXMFL(BMXUPFN,"MULT")_" "_BMXMFL(BMXSUBFN,"MULT") + I 'BMXOTM S BMXMFL(BMXSUBFN,"IENS")="N J S BMXIENS="""" F J=0:1:"_BMXOFF_" S BMXIENS=@(""IEN""_J)_"",""_BMXIENS" + E S BMXMFL(BMXSUBFN,"IENS")="N J S BMXIENS="""" S J=1 S BMXIENS=@(""IEN""_J)_"",""_BMXIENS" + S BMXMFL(BMXSUBFN,"EXEC")=BMXMFL(BMXSUBFN,"MULT")_"X BMXMFL(BMXFN,""IENS"")"_" D GETS^DIQ(BMXFN,BMXIENS,BMXGF(BMXFN),""E"",BMXA) D SETIEN(IEN"_BMXOFF_",BMXFN)" + D F1^BMXSQL(BMXF,BMXFNAM,BMXSUBFN) + ; + Q + ; +PTYPE(BMXGNOD1) ; + ;Traverse pointer chain to retrieve data type of pointed-to field + N BMXFILE + I $P(BMXGNOD1,U,2)'["P" Q BMXGNOD1 + S BMXFILE=$P(BMXGNOD1,U,2) + S BMXFILE=+$P(BMXFILE,"P",2) + S BMXGNOD1=$G(^DD(BMXFILE,".01",0)) + S BMXGNOD1=$$PTYPE(BMXGNOD1) + Q BMXGNOD1 Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL6.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL6.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL6.m (revision 1147) @@ -0,0 +1,346 @@ +BMXSQL6 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ; 2/5/11 10:03pm + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; *1000: WV/SMH Feb 2 2010 - Changes to support GT.M + ; Line EOR+3 used a 2 argument form of $Q which is not + ; in the M 95 standard. Replaced this with a call to $$LAST, + ; a new Extrinsic in this routine. + ; + ; +WRITE ;EP + N BMXFN,C,BMXN,BMXGF,BMXA,BMXFLDF,N,A,IEN0,I + N BMXCNT,BMXCNTB,BMXLEN,BMXLTMP,BMXNUM,BMXORD,BMXTYP + N BMXCFN,BMXCFNX,F,BMXROOT,BMXCID,BMXZ ;From MAKEC + N BMXREC,BMXCHAIN ;TODO: COMMENT AFTER TESTING + N BMXIENS + ;Set up FIELD value for GETS^DIQ call + ; BMXFLD("NAME")="FILE#^FIELD#" + ; Need: BMXFLDN(FieldNumber) + ; and : BMXFLDO(SelectOrder) + ; Get file number -- for now just use first file in array + ; TODO: Set up same main file and related files here and in enumerator + S C=0,BMXN="" + N F + S BMXGF=0 + S F=0 F S F=$O(BMXF(F)) Q:F="" S BMXFN=BMXF(F) D + . S C=0,BMXN=-1 F S BMXN=$O(BMXFLDO(BMXN)) Q:BMXN="" D + . . Q:$P(BMXFLDO(BMXN),U)'=BMXFN + . . I $P(BMXFLDO(BMXN),U,2)=".001" S BMXGF=BMXGF+1 Q + . . S C=C+1 + . . S $P(BMXGF(BMXFN),";",C)=$P(BMXFLDO(BMXN),U,2) + . . S:'$D(BMXGF(BMXFN,"INTERNAL")) BMXGF(BMXFN,"INTERNAL")="E" + . . I $P(BMXFLDO(BMXN),U,3)="I" S BMXGF(BMXFN,"INTERNAL")="IE" + . . S BMXGF=BMXGF+1 + . . Q + . Q + ; + I BMXGF>1 K BMXTK("DISTINCT") ;Distinct supported for only one field + S N=0,BMXFLDF=0,I=1,BMXNUM=0 + D FIELDS + D MAKEC + ; + ; + I BMXCOL D COLTYPE^BMXSQL,ERRTACK^BMXSQL(I) Q ;Column info only + ; + S BMXA="A" + N G,R + ;---> Loop through results global + F S N=$O(^BMXTMP($J,N)) Q:'+N D + . K A + . S R=0 F S R=$O(BMXFO(R)) Q:'+R D ;For each file in ORDER array + . . S IEN0=0 + . . S BMXFN=BMXFO(R) + . . Q:$D(BMXMFL(BMXFN,"MULT")) + . . I R=1 S IEN0=^BMXTMP($J,N) ;Primary file + . . I R>1,$D(BMXFJ("JOIN",BMXFN)) D ;Joined file + . . . S IEN0=0 + . . . S G=BMXFJ("JOIN",BMXFN) + . . . S V=BMXFF(G,"JOIN","IEN") + . . . S @V=^BMXTMP($J,N) + . . . X BMXFF(G,"JOIN") + . . I +IEN0 D ;Removed $D(BMXGF(BMXFN)) for mult fld on extdnd ptr + . . . D SUBFILE(BMXFN) + . . I +IEN0,$D(BMXFLDN(BMXFN,.001)) D SETIEN(IEN0,BMXFN) + . . ; + . . I 0,R>1,$D(BMXMFL(BMXFN,"MULT")) D ;Multiple field + . . . Q:'+IEN0 + . . . Q:'$D(BMXGF(BMXFN)) ;Intervening multiple + . . . ;Call GETS for each subentry in multiple + . . . X BMXMFL(BMXFN,"EXEC") + . S F=0,BMXCNT=0 + . ; + . D RECORD + . D OUT + ; + ; + ;---> Tack on Error Delimiter and any error. + S I=I+1 + D ERRTACK^BMXSQL(I) + D COLTYPE^BMXSQL + Q + ; +SETIEN(BMXIEN,BMXFN) ; + ;B ;SETIEN + Q:'$D(BMXFLDN(BMXFN,.001)) + Q:'+BMXIEN + S A(BMXFN,BMXIEN_",",.001,"E")=BMXIEN + Q + ; +SUBFILE(BMXFN) ; + ;Execute GETS for Any fields in BMXGF(SUBFILE) + ; + ;If the subfile itself has subfiles, call SUBFILE(BMXSUBFN) + ; (Loop through BMXMFL(BMXFN,"SUBFILE",BMXSUBFN)) + I $D(BMXMFL(BMXFN,"SUBFILE")) D + . N BMXSUBFN + . S BMXSUBFN=0 + . F S BMXSUBFN=$O(BMXMFL(BMXFN,"SUBFILE",BMXSUBFN)) Q:'+BMXSUBFN D SUBFILE(BMXSUBFN) + . Q + ; + I $D(BMXGF(BMXFN)) D + . I '$D(BMXMFL(BMXFN,"MULT")) S BMXMSCR=1 D GETS^DIQ(BMXFN,IEN0_",",BMXGF(BMXFN),BMXGF(BMXFN,"INTERNAL"),BMXA) Q + . E X BMXMFL(BMXFN,"EXEC") Q + ; + ; + Q + ; +FIELDS ;---> Write Field Names + ;Field name is TAAAAANAME + ;Where T is the field type (T=Text; D=Date) + ; AAAAA is the field size (see NUMCHAR routine) + ; NAME is the field name + N BMXNUM,BMXFNUM,BMXFNAM,R + K BMXLEN,BMXTYP + S BMXFLDF=1 + S BMXNUM=0 + ;B ;In FIELDS sub + D ;:$D(A) + . I BMXNUM S ^BMXTEMP($J,I)="IEN^",BMXLEN(I)=10,BMXTYP(I)="T",I=I+1 ;TODO: Change from text to number + . S BMXFNUM=0 + . S BMXFNAM=0 + . F R=0:1:(BMXFLDO-1) S BMXFN=$P(BMXFLDO(R),U),BMXFNUM=$P(BMXFLDO(R),U,2) D + . . ;S BMXFNAM=$P(^DD(BMXFN,BMXFNUM,0),"^") ;Get type here + . . S BMXFNAM=BMXFLDN(BMXFN,BMXFNUM) + . . I $P(BMXFLDO(R),U,3)="I" S BMXFNAM="INTERNAL["_BMXFNAM_"]" + . . S BMXFNAM=$TR(BMXFNAM," ","_") + . . I BMXF>1 S BMXFNAM=$TR($P(BMXFNX(BMXFN),".")," ","_")_"."_BMXFNAM + . . S BMXTYP(I)="T" + . . S:$P(BMXFLDO(R),U,5)="D" BMXTYP(I)="D" + . . S:$P(BMXFLDO(R),U,5)="I" BMXTYP(I)="I" + . . S BMXLEN(I)=0 ;Start with length zero + . . ;I $D(BMXFLDA(BMXFN,BMXFNUM)) S BMXFNAM=BMXFLDA(BMXFN,BMXFNUM) + . . I $P(BMXFLDO(R),U,6)]"" S BMXFNAM=$P(BMXFLDO(R),U,6) + . . S ^BMXTEMP($J,I)=BMXFNAM_"^" + . . S I=I+1 + . S ^BMXTEMP($J,I-1)=$E(^BMXTEMP($J,I-1),1,$L(^BMXTEMP($J,I-1))-1)_$C(30) + Q + ; +OUT ; + ;Output to BMXTEMP($J + Q:'$D(BMXREC) + N J,K,L,BMXLENT + S J=0 F S J=$O(BMXREC(J)) Q:'+J D + . S K=0 F S K=$O(BMXREC(J,K)) Q:'+K D + . . I +$O(BMXREC(J,K,0)) D Q ;WP + . . . S L=0,BMXLENT=0 F S L=$O(BMXREC(J,K,L)) Q:'+L D + . . . . S:'$D(^BMXTEMP($J,I)) ^BMXTEMP($J,I)="" + . . . . S:$L(^BMXTEMP($J,I))>250 I=I+1,^BMXTEMP($J,I)="" + . . . . S ^BMXTEMP($J,I)=^BMXTEMP($J,I)_BMXREC(J,K,L) + . . . . S BMXLENT=BMXLENT+$L(BMXREC(J,K,L)) + . . . I BMXLEN(K)250 I=I+1,^BMXTEMP($J,I)="" + . . I $G(BMXTK("DISTINCT"))="TRUE",BMXREC(J,K)]"" Q:$D(^BMXTEMP($J,"DISTINCT",BMXREC(J,K))) + . . S ^BMXTEMP($J,I)=^BMXTEMP($J,I)_BMXREC(J,K) + . . S:$L(BMXREC(J,K))>BMXLEN(K) BMXLEN(K)=$L(BMXREC(J,K)) + . . I $G(BMXTK("DISTINCT"))="TRUE" S ^BMXTEMP($J,"DISTINCT",BMXREC(J,K))="" + Q + ; +RECORD ; + ;For each chain + N C,BMXCQ,BMXLCQ,BMXCQN,BMXLCQN,BMXTRACK,BMXNODE,BMXCNAME,BMXWP + K BMXREC,BMXCHAIN ;TODO: REMOVE AFTER TESTING + D BLDCHN + S BMXREC=0 + D RECINI + S C=0 F S C=$O(BMXCHAIN(C)) Q:'+C D + . ;New chain + . ;Go to the end of the chain, writing record pieces as you go + . ;At the end of the chain, write end-of-record marker,increment record counter, copy previous record + . K BMXTRACK + . S BMXCNAME="BMXCHAIN("_C_")" + . S BMXCQN="" + . S BMXCQ=BMXCNAME F S BMXCQ=$Q(@BMXCQ) Q:BMXCQ="" Q:$P(BMXCQ,",")'=("BMXCHAIN("_C) D + . . S BMXNODE=@BMXCQ + . . I $P(BMXNODE,U,2)="" Q + . . S BMXWP=$P(BMXNODE,U,3) + . . S BMXLCQ=$L(BMXCQ,",") + . . S BMXCQN=$Q(@BMXCQ) + . . S BMXLCQN=$L(BMXCQN,",") + . . I BMXWP="W" D + . . . S BMXREC(BMXREC,$P(BMXNODE,U,2),$P(BMXNODE,U,4))=$P(BMXNODE,U) + . . . S BMXTRACK(BMXLCQ-1,$P(BMXNODE,U,2))=BMXNODE + . . E D + . . . S BMXREC(BMXREC,$P(BMXNODE,U,2))=$P(BMXNODE,U)_U + . . . S BMXTRACK(BMXLCQ,$P(BMXNODE,U,2))=BMXNODE + . . I BMXCQN="" D EOR Q + . . I $P(BMXCQN,",")'=("BMXCHAIN("_C) D EOR Q + . . I BMXLCQN>BMXLCQ Q + . . I (BMXLCQN>$S(BMXWP="W":7,1:6)) D Q + . . . I ($P(BMXCQ,",",1,BMXLCQ-2)=$P(BMXCQN,",",1,BMXLCQN-2)) Q + . . . D EOR ;End of chain + Q + ; +RECINI ; + N J + S BMXREC=BMXREC+1 + F J=1:1:BMXFLDO D + . I $P(BMXFLDO(J-1),U,4)="W" S BMXREC(BMXREC,J,999999)="^" Q + . S BMXREC(BMXREC,J)="^" + Q + ; +EOR ; + ;B ;EOR + N J,K,L,M,I,N + ;S M=$Q(BMXREC(9999999),-1) + S M=$$LAST("BMXREC") + S @M=$TR(@M,"^",$C(30)) + Q:BMXCQN="" + I BMXCQN'="" D RECINI + ;K BMXTRACK(BMXLCQ) ;Also kill all track levels between current and next level + F K BMXTRACK($O(BMXTRACK(999999),-1)) Q:$O(BMXTRACK(9999999),-1)'>BMXLCQN + S J=0 F S J=$O(BMXTRACK(J)) Q:'+J D ;Level + . S K=0 F S K=$O(BMXTRACK(J,K)) Q:'+K D ;Order + . . I $D(BMXTRACK(J,K)) S BMXNODE=BMXTRACK(J,K) S BMXREC(BMXREC,$P(BMXNODE,U,2))=$P(BMXNODE,U)_U + . . S L=0 F S L=$O(BMXTRACK(J,K,L)) Q:'+L D ;wp node + . . . I $D(BMXTRACK(J,K,L)) S BMXNODE=BMXTRACK(J,K,L) S BMXREC(BMXREC,$P(BMXNODE,U,2),L)=$P(BMXNODE,U) + Q + ; +BLDCHN ; + N B + D MAKEB + ;D MAKEC + D BUILD + Q + ; +MAKEC ; + ;MAKE Chain + ;How many chains are there? + S BMXZ=0 S BMXCID=1 K BMXCFN + ; + ; + ;Create BMXCHNP(BMXCID) + S F=0 F S F=$O(BMXMFL(F)) Q:'+F I '$D(BMXMFL("SUBFILE",F)),$D(BMXMFL("PARENT",F)) S BMXMFL("BOTTOM",F)="" + N BMXCB,BMXCHNP,BMXP + S BMXCID=0,BMXCB=0,BMXCHNP=0 + I $D(BMXMFL("BOTTOM")) F S BMXCB=$O(BMXMFL("BOTTOM",BMXCB)) Q:'BMXCB D + . S BMXCID=BMXCID+1,BMXCHNP=BMXCID + . S BMXCHNP(BMXCID)=BMXCB + . S BMXP=BMXCB + . F Q:'$D(BMXMFL("PARENT",BMXP)) S BMXP=BMXMFL("PARENT",BMXP) S BMXCHNP(BMXCID)=BMXP_U_BMXCHNP(BMXCID) + ; + N J,K,L,M + ;Create BMXMFL("BASE")="FILE1^FILE2^...^FILEN" + S F=0,M=0,BMXMFL("BASE")="" F S F=$O(BMXMFL(F)) Q:'+F I (('$D(BMXMFL("PARENT",F)))&('$D(BMXMFL(F,"SUBFILE"))))!(BMXFO(1)=F) S M=M+1,$P(BMXMFL("BASE"),U,M)=F ;Changed to make BMXFO(1) always a member of the base + ; + ;Create BMXCFN(BMXCID,BMXZ,FILE) + I BMXCID=0 S BMXCID=1 + S J=0,BMXZ=0 F J=1:1:BMXCID D + . I BMXMFL("BASE")]"" F L=1:1:$L(BMXMFL("BASE"),"^") S F=$P(BMXMFL("BASE"),"^",L) D + . . S BMXZ=BMXZ+100 + . . S BMXCFN(J,BMXZ,F)="" + . I +BMXCHNP F K=1:1:$L(BMXCHNP(J),"^") S F=$P(BMXCHNP(J),"^",K) D + . . Q:F=BMXFO(1) ;BMXFO(1) Is always a member of the base + . . S BMXZ=BMXZ+100 + . . S BMXCFN(J,BMXZ,F)="" + ; + ; + ;B ;FIXCFN + D FIXCFN + Q + ; +BUILD ;Building BMXCHAIN( + N BMXIEN,BMXCID,BMXFLD,BMXCS,BMXINT,BMXCFNC,BMXCFIEN + S BMXCID=0,BMXIEN=0 + F S BMXCID=$O(BMXCFN(BMXCID)) Q:'+BMXCID D + . S BMXCFNC=0 F S BMXCFNC=$O(BMXCFN(BMXCID,BMXCFNC)) Q:'+BMXCFNC S BMXCFN=+BMXCFN(BMXCID,BMXCFNC) D + . . S BMXIEN=0 F S BMXIEN=$O(B(BMXCFN,BMXIEN)) Q:BMXIEN="" D + . . . S $P(BMXCFN(BMXCID,BMXCFNC),U,2)=BMXIEN + . . . S BMXFLD=0 F S BMXFLD=$O(B(BMXCFN,BMXIEN,BMXFLD)) Q:'+BMXFLD D + . . . . S BMXINT="D" F S BMXINT=$O(B(BMXCFN,BMXIEN,BMXFLD,BMXINT)) Q:BMXINT="" D + . . . . . Q:'$D(BMXFLDOX(BMXCFN,BMXFLD,BMXINT)) + . . . . . I $P(BMXFLDO(BMXFLDOX(BMXCFN,BMXFLD,BMXINT)),U,4)="W" D MCWP Q + . . . . . D FIXIEN + . . . . . S BMXCS="BMXCHAIN("_BMXCID_","_$S($L(BMXIEN,",")=2:1,1:2)_","_BMXCFIEN_","_BMXFLD_","_$C(34)_BMXINT_$C(34)_")" + . . . . . S @BMXCS=B(BMXCFN,BMXIEN,BMXFLD,BMXINT)_U_(BMXFLDOX(BMXCFN,BMXFLD,BMXINT)+1) + Q + ; +FIXIEN ; + N BMXC,BMXCFN1,BMXOFF + S BMXC=BMXCFNC + S BMXCFIEN=BMXCFN_","_$P(BMXIEN,",",$L(BMXIEN,",")) + S BMXOFF=1 + F S BMXC=$O(BMXCFN(BMXCID,BMXC),-1) Q:'+BMXC D + . S BMXCFN1=+BMXCFN(BMXCID,BMXC) + . I '$D(BMXMFL(BMXCFN,"OTM")) D + . . I '$D(BMXMFL(BMXCFN1,"SUBFILE",BMXCFN)) Q + . . S BMXCFIEN=BMXCFN1_","_$P(BMXIEN,",",$L(BMXIEN,",")-BMXOFF)_","_BMXCFIEN + . I $D(BMXMFL(BMXCFN,"OTM")) D + . . I '$D(BMXMFL(BMXCFN1,"SUBFILE",BMXCFN)) Q + . . S BMXCFIEN=BMXCFN1_$P(BMXCFN(BMXCID,BMXC),U,2)_","_BMXCFIEN + . S BMXOFF=BMXOFF+1 + ; + ; + Q + ; +FIXCFN ; + N J,K,L + S J=0 F S J=$O(BMXCFN(J)) Q:'+J D + . S K=0 F S K=$O(BMXCFN(J,K)) Q:'+K D + . . S L=0 F S L=$O(BMXCFN(J,K,L)) Q:'+L D + . . . K BMXCFN(J,K,L) + . . . S BMXCFN(J,K)=L + ; + Q + ; +MCWP ; + ;MAKEC Process WP Field + N BMXIENL,BMXWP + S BMXIENL=1 + S:$L(BMXIEN,",")>2 BMXIENL=2 + S BMXWP=0 + ; + F S BMXWP=$O(B(BMXCFN,BMXIEN,BMXFLD,BMXWP)) Q:'+BMXWP D + . S BMXCS="BMXCHAIN("_BMXCID_","_BMXIENL_","_BMXCFN_BMXIEN_","_BMXFLD_","_$C(34)_BMXINT_$C(34)_","_BMXWP_")" + . S @BMXCS=B(BMXCFN,BMXIEN,BMXFLD,BMXWP)_U_(BMXFLDOX(BMXCFN,BMXFLD,BMXINT)+1)_U_"W"_U_BMXWP + Q + ; + ; +MAKEB ; + N BMXFILE,BMXIEN,BMXFLD,BMXINT + N BMXSUB,BMXIENR + S BMXFILE=0 F S BMXFILE=$O(A(BMXFILE)) Q:'+BMXFILE D + . S BMXIEN=0 F S BMXIEN=$O(A(BMXFILE,BMXIEN)) Q:'+BMXIEN D + . . S BMXFLD=0 F S BMXFLD=$O(A(BMXFILE,BMXIEN,BMXFLD)) Q:'+BMXFLD D + . . . S BMXINT=0 F S BMXINT=$O(A(BMXFILE,BMXIEN,BMXFLD,BMXINT)) Q:BMXINT="" D + . . . . S BMXIENR=$$REVERSE(BMXIEN) + . . . . S BMXSUB="B("_BMXFILE_","_$C(34)_BMXIENR_$C(34)_","_BMXFLD_","_$C(34)_BMXINT_$C(34)_")" + . . . . I $D(BMXFLDOX(BMXFILE,BMXFLD,BMXINT)),$P(BMXFLDO(BMXFLDOX(BMXFILE,BMXFLD,BMXINT)),U,5)="D" D Q + . . . . . S @BMXSUB=$TR(A(BMXFILE,BMXIEN,BMXFLD,BMXINT),"@"," ") + . . . . S @BMXSUB=A(BMXFILE,BMXIEN,BMXFLD,BMXINT) + Q + ; +REVERSE(BMXIEN) ; + N J,T,C + S C=1 + F J=$L(BMXIEN,","):-1:1 D + . S $P(T,",",C)=$P(BMXIEN,",",J) + . S C=C+1 + Q T +LAST(VAR) ; Get last entry in an array //SMH new code + N SUB1 S SUB1=$O(@VAR@(""),-1) + N SUB2 S SUB2=$O(@VAR@(SUB1,""),-1) + N SUB3 S SUB3=$O(@VAR@(SUB1,SUB2,""),-1) + I SUB3="" Q $NA(@VAR@(SUB1,SUB2)) + E Q $NA(@VAR@(SUB1,SUB2,SUB3)) + Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL7.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL7.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL7.m (revision 1147) @@ -0,0 +1,232 @@ +BMXSQL7 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; +CHKCR(BMXFNUM,BMXFLDNU,BMXRET) ;Returns cross reference to iterate on for related file + N BMXREF,BMXHIT,BMXRNOD,BMXTMP,BMXTMPV,BMXTMPI,BMXTMPP,BMXPFFN,BMXPFF,Q + N BMXHIT,BMXREF,BMXGL,BMXNOD,BMXRNAM,BMXTMPL,BMXTMPN,BMXTST + ; + S BMXNOD=^DD(BMXFNUM,BMXFLDNU,0) + S BMXGL=^DIC(BMXFNUM,0,"GL") ;Subfile global + S BMXREF=0,BMXHIT=0,Q=$C(34),BMXRET="" + F S BMXREF=$O(^DD(BMXFNUM,BMXFLDNU,1,BMXREF)) Q:'+BMXREF D Q:BMXHIT + . Q:'$D(^DD(BMXFNUM,BMXFLDNU,1,BMXREF,0)) + . S BMXRNOD=^DD(BMXFNUM,BMXFLDNU,1,BMXREF,0) + . Q:$P(BMXRNOD,U,3)]"" + . S BMXRNAM=$P(BMXRNOD,U,2) + . S BMXTMP=BMXGL_Q_BMXRNAM_Q_")" + . S BMXTST=$P(BMXTMP,")")_",IEN0," + . Q:'$D(@BMXTMP) + . S BMXTMPV=0,BMXTMPV=$O(@BMXTMP@(BMXTMPV)) + . Q:BMXTMPV="" + . S BMXTMP=BMXGL_Q_BMXRNAM_Q_","_Q_BMXTMPV_Q_")" + . S BMXTMPI=0,BMXTMPI=$O(@BMXTMP@(BMXTMPI)) + . S BMXTMP=$S(BMXGL[",":$P(BMXGL,",")_")",1:$P(BMXGL,"(")) + . Q:'$D(@BMXTMP@(BMXTMPI)) + . S BMXTMPL=$P(BMXNOD,U,4) + . S BMXTMPP=$P(BMXTMPL,";",2) + . S BMXTMPL=$P(BMXTMPL,";") + . Q:BMXTMPL="" + . S BMXTMP=BMXGL_BMXTMPI_")" + . Q:'$D(@BMXTMP@(BMXTMPL)) + . S BMXTMPN=@BMXTMP@(BMXTMPL) + . S BMXTMPP=$P(BMXTMPN,"^",BMXTMPP) + . I BMXTMPP=BMXTMPV S BMXRET=BMXTST,BMXHIT=1 + Q BMXHIT + ; + ; +WHERE ;EP - WHERE-clause processing + ; + ;Set up the defualt iterator in BMXX(1) to scan the entire file. + ;For now, just use first file in the FROM group + ;Later, pick the smallest file if more than one file + ; + ;Set up BMXFF array for each expression element + ; BMXFF(n)=FILENAME^FIELDNAME^OPERATOR^VALUE^FILENUMBER^FIELDNUMBER + ; ^FILE GLOBAL^FIELD DATA LOCATION + ; BMXFF(n,0)=Field descriptor ^DD(FILE,FIELD,0) + ; + N BMXGL,BMXOP,BMXTYP,BMXV,BMXV1,BMXV2,BMXFILE,BMXTMP + N BMXINTNL,BMXTMPLT + N BMXIEN + S BMXGL=^DIC(BMXFO(1),0,"GL") + S BMXX=1 + S BMXX(1)="S D0=0 F S D0=$O("_BMXGL_"D0)) Q:'+D0 Q:BMXM>BMXXMAX " + S BMXTMP=BMXGL + I BMXTMP["," S BMXTMP=$TR(BMXTMP,",",")") + E S BMXTMP=$P(BMXTMP,"(",1) + I $D(@BMXTMP@("B")) D + . S BMXX(1)="S BMXTMP=0 F S BMXTMP=$O("_BMXGL_$C(34)_"B"_$C(34)_",BMXTMP)) Q:BMXTMP="""" S D0=0 F S D0=$O("_BMXGL_$C(34)_"B"_$C(34)_",BMXTMP,D0)) Q:'+D0 Q:BMXM>BMXXMAX " + ; + ;--->BMXFF array: + ; + S T=$G(BMXTK("WHERE")) + S BMXFF=0,C=0 + Q:'+T + F S T=$O(BMXTK(T)) Q:'+T Q:T=$G(BMXTK("ORDER BY")) Q:T=$G(BMXTK("GROUP BY")) D Q:$D(BMXERR) + . ;Get the file of the field + . I "AND^OR^(^)"[BMXTK(T) D Q + . . S C=C+1 + . . S BMXFF(C)=BMXTK(T) + . . S BMXFF=C + . S BMXTK(T)=$TR(BMXTK(T),"_"," ") + . S BMXTK(T)=$TR(BMXTK(T),"'","") + . S BMXINTNL=0 + . S BMXTMPLT=0 + . S BMXIEN=0 + . I BMXTK(T)["INTERNAL[" S BMXINTNL=1,BMXTK(T)=$P(BMXTK(T),"[",2),BMXTK(T)=$P(BMXTK(T),"]",1) + . I BMXTK(T)["TEMPLATE[" S BMXTMPLT=1,BMXTK(T)=$P(BMXTK(T),"[",2),BMXTK(T)=$P(BMXTK(T),"]",1),BMXIEN=1 + . I BMXTK(T)["BMXIEN" S BMXIEN=1 + . S BMXFILE=$$FLDFILE^BMXSQL2(BMXTK(T)) + . Q:$D(BMXERR) + . S C=C+1 + . S BMXFF=C ;This is a count of the where fields + . I BMXFILE]"" D + . . S $P(BMXFF(C),U,1)=$P(BMXFILE,U,1) ;FILENAME + . . S $P(BMXFF(C),U,2)=$P(BMXFILE,U,2) ;FIELDNAME + . . S $P(BMXFF(C),U,5)=$P(BMXFILE,U,3) ;FILENUMBER + . . S $P(BMXFF(C),U,6)=$P(BMXFILE,U,4) ;FIELDNUMBER + . . I $P(BMXFILE,U,3),$D(^DIC($P(BMXFILE,U,3),0,"GL")) S $P(BMXFF(C),U,7)=^DIC($P(BMXFILE,U,3),0,"GL") + . . I BMXIEN S BMXFF(C,0)="IEN",BMXFF(C,"IEN")=1,BMXFF(C,"TYPE")="IEN" + . . E S BMXFF(C,0)=$S(+$P(BMXFILE,U,3):^DD($P(BMXFILE,U,3),$P(BMXFILE,U,4),0),1:"") + . . I BMXINTNL S BMXFF(C,"INTERNAL")=1 + . ; + . ;If BMXFF(C) is a pointer, traverse pointer chain to retrieve type + . I $P(BMXFF(C,0),U,2)["P" D + . . ;B ;WHERE Pointer Type + . . N BMXFILN,BMXFLDN,BMXDD + . . S BMXDD=BMXFF(C,0) + . . F Q:$P(BMXDD,U,2)'["P" D:$P(BMXDD,U,2)["P" + . . . S BMXFILN=$P(BMXDD,U,2) + . . . S BMXFILN=+$P(BMXFILN,"P",2) + . . . S BMXDD=^DD(BMXFILN,".01",0) + . . S BMXFF(C,"TYPE")=$S($P(BMXDD,U,2)["D":"DATE",$P(BMXDD,U,2)["S":"SET",1:"OTHER") + . . I BMXFF(C,"TYPE")="SET" S $P(BMXFF(C,"TYPE"),U,2)=$P(BMXDD,U,3) + . ;B ;WHERE Set Type + . I ($P(BMXFF(C,0),U,2)["S")!($P($G(BMXFF(C,"TYPE")),U)="SET") D ;Set + . . N BMXSET,BMXSETP + . . I $P(BMXFF(C,0),U,2)["S" D + . . . S BMXFF(C,"TYPE")="SET" + . . . S $P(BMXFF(C,"TYPE"),U,2)=$P(BMXFF(C,0),U,3) + . . S BMXSET=$P(BMXFF(C,"TYPE"),U,2) + . . F J=1:1:$L(BMXSET,";") D + . . . S BMXSETP=$P(BMXSET,";",J) + . . . Q:BMXSETP="" + . . . S BMXFF(C,"SET",$P(BMXSETP,":",2))=$P(BMXSETP,":") + . ; + . ;Set up comparisons based on operators + . S T=T+1 + . S BMXOP=BMXTK(T) + . I BMXTMPLT S BMXOP="=" + . I "^<^>^=^[^<>^>=^<=^LIKE"[BMXOP D Q + . . S $P(BMXFF(C),U,3)=BMXTK(T) + . . ;Get the comparison value + . . S T=T+1 + . . S BMXTMP=BMXTK(T) + . . S BMXTMP=$TR(BMXTMP,"'","") + . . I BMXOP="LIKE" S BMXTMP=$P(BMXTMP,"%"),$P(BMXFF(C),U,4)=BMXTMP Q + . . I BMXTMPLT D TMPLATE Q + . . I BMXTMP="*" S T=T+1,BMXTMP=BMXTK(T) D OTM Q + . . I BMXTMP[".",BMXTK(T)'["'" D ;This is a join ;TODO: Extended pointers + . . . ;Setting BMXFJ("JOIN" + . . . S BMXTMP=BMXTK(T) + . . . I $D(BMXF($P(BMXTMP,"."))),BMXF($P(BMXTMP,"."))=BMXFO(1) D Q + . . . . S BMXTMP=BMXTK(T-2) + . . . . D OTM + . . . N BMXJN + . . . S BMXFF(C,"JOIN")="Pointer chain" + . . . S BMXJN=+$P($P(BMXFF(C,0),U,2),"P",2) + . . . S BMXFJ("JOIN",+$P($P(BMXFF(C,0),U,2),"P",2))=C + . . . S:+$P($P(BMXFF(C,0),U,2),"P",2)=2 BMXFJ("JOIN",9000001)=C ;IHS Only -- auto join PATIENT to VA PATIENT + . . I ($P(BMXFF(C,0),U,2)["D")!($G(BMXFF(C,"TYPE"))="DATE") D ;Date + . . . Q:$D(BMXFF(C,"INTERNAL")) + . . . I BMXTMP]"" S X=BMXTMP,%DT="T" D ^%DT S BMXTMP=Y + . . I $P($G(BMXFF(C,"TYPE")),U)="SET" D + . . . Q:$D(BMXFF(C,"INTERNAL")) + . . . Q:BMXTMP="" + . . . I $G(BMXFF(C,"SET",BMXTMP))="" S BMXTMP="ZZZZZZ" Q + . . . S BMXTMP=$G(BMXFF(C,"SET",BMXTMP)) + . . S $P(BMXFF(C),U,4)=BMXTMP + . . Q + . I BMXOP="BETWEEN" D + . . S $P(BMXFF(C),U,3)="BETWEEN" + . . ;Get the comparison value + . . S T=T+1 + . . S BMXV1=BMXTK(T) + . . S:BMXV1["'" BMXV1=$P(BMXV1,"'",2) + . . S T=T+1 + . . I BMXTK(T)'="AND" S BMXERR="'BETWEEN' VALUES NOT SPECIFIED" D ERROR Q + . . S T=T+1 + . . S BMXV2=BMXTK(T) + . . S:BMXV2["'" BMXV2=$P(BMXV2,"'",2) + . . I ($P(BMXFF(C,0),U,2)["D")!($G(BMXFF(C,"TYPE"))="DATE") D ;Date + . . . Q:$D(BMXFF(C,"INTERNAL")) + . . . S X=BMXV1,%DT="T" D ^%DT S BMXV1=Y + . . . S X=BMXV2,%DT="T" D ^%DT S BMXV2=Y + . . I BMXV1>BMXV2 S BMXTMP=BMXV1,BMXV1=BMXV2,BMXV2=BMXTMP + . . S $P(BMXFF(C),U,4)=BMXV1_"~"_BMXV2 + . . Q + . I $P(BMXFF(C),U,3)="" S BMXERR="INVALID OPERATOR" D ERROR Q + . I $D(BMXTK(T+1)),BMXTK(T+1)["[INDEX:" D + . . S T=T+1 + . . N BMXIND + . . S BMXIND=$P(BMXTK(T),"INDEX:",2) + . . S:BMXIND["]" BMXIND=$P(BMXIND,"]") + . . S:BMXIND["'" BMXIND=$P(BMXIND,"'",2) + . . S BMXFF("INDEX")=BMXIND + . Q + ; + Q:$D(BMXERR) + D JOIN^BMXSQL4 + Q + ; +TMPLATE ; + N BMXTNUM,BMXTNOD + I BMXTMP["[" S BMXTMP=$P(BMXTMP,"[",2),BMXTMP=$P(BMXTMP,"]") + S BMXTMP=$TR(BMXTMP,"_"," ") + ;Test template validity + I '$D(^DIBT("B",BMXTMP)) S BMXERR="TEMPLATE NOT FOUND" D ERROR Q + S BMXTNUM=$O(^DIBT("B",BMXTMP,0)) + I '$D(^DIBT(BMXTNUM,0)) S BMXERR="TEMPLATE NOT FOUND" D ERROR Q + S BMXTNOD=^DIBT(BMXTNUM,0) + I $P(BMXTNOD,U,4)'=$P(BMXFF(C),U,5) S BMXERR="TEMPLATE DOES NOT MATCH FILE" D ERROR Q + I '$D(^DIBT(BMXTNUM,1)) S BMXERR="TEMPLATE HAS NO ENTRIES" D ERROR Q + S BMXFF(C,0)="IEN",BMXFF(C,"IEN")="TEMPLATE",BMXFF(C,"TYPE")="IEN" + S $P(BMXFF(C),U,4)=BMXTMP + ; + Q + ; +OTM ;One-To-Many + N BMXUPFN,BMXSUBFN,BMXA,BMXB,BMXSBFLD,BMXFNAM + I BMXTMP["INTERNAL[" S BMXTMP=$P(BMXTMP,"INTERNAL[",2),BMXTMP=$P(BMXTMP,"]") + S BMXUPFN=BMXFO(1) + S BMXA=$TR($P(BMXTMP,"."),"_"," ") + S BMXB=$TR($P(BMXTMP,".",2),"_"," ") + S BMXFNAM=BMXB ;Required by SETMFL. Won't work if filename BMXB [ "." + ;Get the subfile + I '$D(BMXF(BMXA)) S BMXERR="Related File Not Found" Q + S BMXSUBFN=BMXF(BMXA) + I '$D(^DD(BMXSUBFN,0)) S BMXERR="Related file not found" Q + ;Get the field that points to the main file + I '$D(^DD(BMXSUBFN,"B",BMXB)) S BMXERR="Related field not found" Q + S BMXSBFLD=$O(^DD(BMXSUBFN,"B",BMXB,0)) + I '+BMXSBFLD S BMXERR="Related field not found" Q + ; + ;Find a normal index on that field + ;Set up for call to CHKCR^BMXSQL7 + N BMXEXEC + I '$$CHKCR^BMXSQL7(BMXSUBFN,BMXSBFLD,.BMXEXEC) S BMXERR="Related File not indexed" Q + ; + ; + S BMXFF(C,"JOIN")="One-to-many Join" + ; + ;Call SETMFL^BMXSQL5 to set up the iteration code + D SETMFL^BMXSQL5(BMXUPFN,BMXSUBFN,BMXEXEC,1,1) + ; + ; + ;Upfile is the mainfile, Subfile is the related file + ;BMXOFF is 1 but What is BMXGL? + ; + Q + ; +ERROR Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL91.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL91.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXSQL91.m (revision 1147) @@ -0,0 +1,141 @@ +BMXSQL91 ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + ;Below is dead code, but keep for later +SETX2 ;Don't need this unless porting to machine with + ;local variable size limitations + N F,LVL,ROOT,START + S LVL=1,START=1 + S ROOT="BMXY" + F F=1:1:BMXFF D Q:$D(BMXERR) + . S BMX=BMXFF(F) + . I BMX="(" D Q ;Increment level + . . S LVL=LVL+1 + . . ;S ROOT=$S(ROOT["(":$P(ROOT,")")_","_0_")",1:ROOT_"("_0_")") + . . ;Get operator following close paren corresponding to this open + . . ;If op = OR then set up FOR loop in zeroeth node + . . ;if op = AND then set up + . I BMX=")" D Q ;Decrement level + . . S LVL=LVL-1 + . . I LVL=1,$D(BMXFF(F+1)),BMXFF(F+1)="&" D Q + . . . S BMXX=BMXX+1 + . . . S BMXX(BMXX)="" + . . . F J=START:1:F S BMXX(BMXX)=BMXX(BMXX)_BMXFF(J) + . . . S START=F+2 + . . . ;S BMXX(BMXX)="I "_BMXX(BMXX)_" X BMXX("_BMXX+1_")" + . ; I BMX="AND" D Q ;Chain to previous expression at current level + . ; I BMX="OR" D Q ;Create FOR-loop to execute screens + ; + Q + ; + ; + ;S F=0 F S F=$O(BMXMFL(F)) Q:'+F S:'$D(BMXMFL(F,"SUBFILE")) BMXMFL("NOSUBFILE",F)="" + ;I $D(BMXMFL("NOSUBFILE")) S F=0 F S F=$O(BMXMFL("NOSUBFILE",F)) Q:'+F D MAKEC1 + ;I $D(BMXMFL("SUBFILE")) S F=0 F S F=$O(BMXMFL("SUBFILE",F)) Q:'+F D MAKEC1 ;S BMXROOTZ=BMXZ+100 + ; + Q +MAKEC1 ; + I '$D(BMXMFL(F,"SUBFILE")),'$D(BMXMFL(F,"MULT")) S BMXZ=BMXZ+100,BMXCFN(BMXCID,BMXZ,F)="" Q + Q:'$D(BMXMFL(F,"SUBFILE")) + Q:$D(BMXMFL(F,"MULT")) + S BMXROOT=F + S BMXROOTZ=BMXZ+100 + S BMXROOTC=BMXCID + D MCNT(F) + Q + ; +MCNT(F) ; + N S + ;B ;MCNT + I '$D(BMXMFL(F,"SUBFILE")) D MCNT2 Q + S S=0 F S S=$O(BMXMFL(F,"SUBFILE",S)) Q:'+S S:'$D(BMXCFN(BMXCID,BMXZ,F)) BMXZ=BMXZ+100,BMXCFN(BMXCID,BMXZ,F)="" S BMXZ=BMXZ+100,BMXCFN(BMXCID,BMXZ,S)="",BMXCFNX(S,F)="" D MCNT(S) + Q + ; +MCNT2 ; + ;B ;Back-chain + ;TODO: RESTART HERE -- $O(BMXCFN(BMXCID,0)) NEEDS TO BE CHANGED TO SOMETHING BESIDES 0 + N BMXFTOP,BMXFBACK + F S BMXFTOP=$O(BMXCFN(BMXROOTC,BMXROOTZ,0)) Q:BMXFTOP=BMXROOT S BMXFBACK=$O(BMXCFNX(BMXFTOP,0)) S BMXROOTZ=BMXROOTZ-1,BMXCFN(BMXCID,BMXROOTZ,BMXFBACK)="" + S BMXCID=BMXCID+1,BMXROOTC=BMXCID + ;Get the root files + I $D(BMXMFL("NOSUBFILE")) D + . N F + . S F=0 F S F=$O(BMXMFL("NOSUBFILE",F)) Q:'+F D + . . Q:$D(BMXMFL(F,"MULT")) + . . Q:F=BMXROOT + . . S BMXZ=BMXZ+100 + . . S BMXCFN(BMXCID,BMXZ,F)="" + S BMXROOTZ=BMXZ+100 + Q + ; + ; +ITER ;Iterate through result array A + S BMXCNT=BMXFLDO ;Field count + S F=0 + S:BMXNUM ^BMXTEMP($J,I)=IEN0_"^" + S BMXCNTB=0 + S BMXORD=BMXNUM + N BMXONOD + N BMXINT + ;B ;WRITE Before REORG + N M,N S N=0 + D REORG + ;B ;WRITE After REORG + F S N=$O(M(N)) Q:'+N D + . S O=0 + . F O=1:1:$L(M(N),U) S BMXFLDO(O-1,"IEN0")=$P(M(N),U,O) + . S BMXORD=BMXNUM + . D OA + Q + ; +REORG N R,IEN,J,CONT,TEST + F R=0:1:BMXFLDO-1 S IEN(R)=0 + F J=1:1 D Q:'CONT + . S CONT=0 + . F R=1:1:BMXFLDO D + . . S TEST=$O(A(+BMXFLDO(R-1),IEN(R-1))) + . . I +TEST S IEN(R-1)=TEST,CONT=1 + . . S $P(M(J),U,R)=IEN(R-1) + . Q + I M(J)=M(J-1) K M(J) + Q + ; + ; +OA ; + I $D(A) F R=0:1:(BMXFLDO-1) S F=$P(BMXFLDO(R),U,2),BMXFN=$P(BMXFLDO(R),U),BMXINT=$P(BMXFLDO(R),U,3) D S:(R+1)BMXLEN(BMXORD) BMXLEN(BMXORD)=BMXLTMP + . . . Q + . . D ;It's a multiple. Implement in next phase + . . . ;S BMXMCT=BMXMCT+1 + . . . ;S BMXMCT(BMXMCT)=BMXFN_U_F + . . . Q ;Process A( for multiple field + . . Q + . E D ;Not a multiple + . . S I=I+1 + . . I $G(BMXTK("DISTINCT"))="TRUE" D Q + . . . Q:A(BMXFN,IEN0,F,BMXINT)="" + . . . I $D(^BMXTMPD($J,A(BMXFN,IEN0,F,BMXINT))) Q + . . . S ^BMXTMPD($J,A(BMXFN,IEN0,F,BMXINT))="" + . . . S ^BMXTEMP($J,I)=A(BMXFN,IEN0,F,BMXINT) + . . . S:$L(A(BMXFN,IEN0,F,BMXINT))>BMXLEN(BMXORD) BMXLEN(BMXORD)=$L(A(BMXFN,IEN0,F,BMXINT)) + . . . Q + . . S ^BMXTEMP($J,I)=A(BMXFN,IEN0,F,BMXINT) + . . S:$L(A(BMXFN,IEN0,F,BMXINT))>BMXLEN(BMXORD) BMXLEN(BMXORD)=$L(A(BMXFN,IEN0,F,BMXINT)) + . Q + ;---> Set data in result global. + I $D(^BMXTEMP($J,I)) S ^BMXTEMP($J,I)=^BMXTEMP($J,I)_$C(30) +ZZZ Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXTABLE.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXTABLE.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXTABLE.m (revision 1147) @@ -0,0 +1,7 @@ +BMXTABLE ; IHS/OIT/HMW - BMX RETURN ENTIRE TABLE ; + ;;4.1000;BMX;;Apr 17, 2011 + ; +TABLE(BMXGBL,BMXFL,BMXMX) ;EP + ; + D FIND^BMXFIND(.BMXGBL,BMXFL,"*",,,BMXMX,,,,1) + Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXTRS.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXTRS.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXTRS.m (revision 1147) @@ -0,0 +1,42 @@ +BMXTRS ; IHS/OIT/HMW - UPPERCASE-LOWERCASE ; + ;;4.1000;BMX;;Apr 17, 2011 + ; +T(X) ;EP + ;---> Translate word to mixed case. + ; + N BMXWORD,I + I '$D(X) Q "" + I X="^" Q X + I X=" " Q X + ;-----> REMOVE LEADING INAPPROPRIATE CHARACTERS IF PRESENT. + F Q:$E(X)'?1P S X=$E(X,2,99) + ;-----> CHANGE FIRST LETTER TO UPPERCASE: + S BMXWORD=$E(X) + I $E(BMXWORD)?1L S BMXWORD=$C($A($E(BMXWORD))-32) + ;-----> DO NEXT CHARACTER + F I=2:1:$L(X) D CHAR + ;-----> REMOVE TRAILING SPACE OR QUOTE. + F Q:""" "'[$E(BMXWORD,$L(BMXWORD)) D + .S BMXWORD=$E(BMXWORD,1,($L(BMXWORD)-1)) + ;-----> RESET X EQUAL TO RESULT +EOJ ; + Q BMXWORD + ; +CHAR ; + ;-----> IF THE CHARACTER IS UPPERCASE AND PREVIOUS CHARACTER IS NOT + ;-----> PUNCTUATION (EXCEPT FOR AN APOSTROPHY) OR A SPACE, + ;-----> THEN CHANGE CHARACTER TO LOWERCASE: + I ($E(X,I)?1U)&(($E(X,I-1)'?1P)!($E(X,I-1)="'")) D Q + .S BMXWORD=BMXWORD_$C($A($E(X,I))+32) + ; + ;-----> IF THE CHARACTER IS LOWERCASE AND PREVIOUS CHARACTER IS + ;-----> PUNCTUATION (BUT NOT AN APOSTROPHY) OR A SPACE, THEN CHANGE + ;-----> CHARACTER TO UPPERCASE: + I $E(X,I)?1L,$E(X,I-1)?1P,$E(X,I-1)'="'" D Q + .S BMXWORD=BMXWORD_$C($A($E(X,I))-32) + ; + ;-----> ADD CHARACTER TO BMXWORD STRING WITHOUT MODIFICATION. + ;-----> "\" PLACED BEFORE A LETTER FORCES IT TO BE UPPERCASE; + ;-----> HERE REMOVE ANY "\"'s. + I $E(X,I)'="\" S BMXWORD=BMXWORD_$E(X,I) + Q Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXUTL1.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXUTL1.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXUTL1.m (revision 1147) @@ -0,0 +1,330 @@ +BMXUTL1 ; IHS/OIT/HMW - UTIL: PATIENT DEMOGRAPHICS ; + ;;4.1000;BMX;;Apr 17, 2011 + ;;Stolen from:* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER * + ;; UTILITY: PATIENT DEMOGRAPHICS. + ; + ; + ;---------- +NAME(DFN,ORDER) ;EP + ;---> Return text of Patient Name. + ;---> Parameters: + ; 1 - DFN (req) Patient's IEN (DFN). + ; 2 - ORDER (opt) ""/0=Last,First 2=First Only + ; 1=First Last 3=Last Only + ; + Q:'$G(DFN) "NO PATIENT" + Q:'$D(^DPT(DFN,0)) "Unknown" + N X S X=$P(^DPT(DFN,0),U) + Q:'$G(ORDER) X + S X=$$FL(X) + Q:ORDER=1 X + Q:ORDER=2 $P(X," ") + Q:ORDER=3 $P(X," ",2) + Q "UNKNOWN ORDER" + ; + ; + ;---------- +FL(X) ;EP + ;---> Switch First and Last Names. + Q $P($P(X,",",2)," ")_" "_$P(X,",") + ; + ; + ;---------- +DOB(DFN) ;EP + ;---> Return Patient's Date of Birth in Fileman format. + ;---> Parameters: + ; 1 - DFN (req) Patient's IEN (DFN). + ; + Q:'$G(DFN) "NO PATIENT" + Q:'$P($G(^DPT(DFN,0)),U,3) "NOT ENTERED" + Q $P(^DPT(DFN,0),U,3) + ; + ; + ;---------- +DOBF(DFN,BMXDT,BMXNOA) ;EP + ;---> Date of Birth formatted "09-Sep-1994 (35 Months)" + ;---> Parameters: + ; 1 - DFN (req) Patient's IEN (DFN). + ; 2 - BMXDT (opt) Date on which Age should be calculated. + ; 3 - BMXNOA (opt) 1=No age (don't append age). + ; + N X,Y + S X=$$DOB($G(DFN)) + Q:'X X + S X=$$TXDT1^BMXUTL5(X) + Q:$G(BMXNOA) X + S Y=$$AGEF(DFN,$G(BMXDT)) + S:Y["DECEASED" Y="DECEASED" + S X=X_" ("_Y_")" + Q X + ; + ; + ;---------- +AGE(DFN,BMXZ,BMXDT) ;EP + ;---> Return Patient's Age. + ;---> Parameters: + ; 1 - DFN (req) IEN in PATIENT File. + ; 2 - BMXZ (opt) BMXZ=1,2,3 1=years, 2=months, 3=days. + ; 2 will be assumed if not passed. + ; 3 - BMXDT (opt) Date on which Age should be calculated. + ; + N BMXDOB,X,X1,X2 S:$G(BMXZ)="" BMXZ=2 + Q:'$G(DFN) "NO PATIENT" + S BMXDOB=$$DOB(DFN) + Q:'BMXDOB "Unknown" + I '$G(BMXDT)&($$DECEASED(DFN)) D Q X + .S X="DECEASED: "_$$TXDT1^BMXUTL5(+^DPT(DFN,.35)) + S:'$G(DT) DT=$$DT^XLFDT + S:'$G(BMXDT) BMXDT=DT + Q:BMXDT Age in Years. + N BMXAGEY,BMXAGEM,BMXD1,BMXD2,BMXM1,BMXM2,BMXY1,BMXY2 + S BMXM1=$E(BMXDOB,4,7),BMXM2=$E(BMXDT,4,7) + S BMXY1=$E(BMXDOB,1,3),BMXY2=$E(BMXDT,1,3) + S BMXAGEY=BMXY2-BMXY1 S:BMXM2 Age in Months. + S BMXD1=$E(BMXM1,3,4),BMXM1=$E(BMXM1,1,2) + S BMXD2=$E(BMXM2,3,4),BMXM2=$E(BMXM2,1,2) + S BMXAGEM=12*BMXAGEY + I BMXM2=BMXM1&(BMXD2BMXM1 S BMXAGEM=BMXAGEM+BMXM2-BMXM1 + I BMXM2 Age in Days. + S X1=BMXDT,X2=BMXDOB + D ^%DTC + Q X + ; + ; + ;---------- +AGEF(DFN,BMXDT) ;EP + ;---> Age formatted "35 Months" or "23 Years" + ;---> Parameters: + ; 1 - DFN (req) Patient's IEN (DFN). + ; 2 - BMXDT (opt) Date on which Age should be calculated. + ; + N Y + S Y=$$AGE(DFN,2,$G(BMXDT)) + Q:Y["DECEASED" Y + Q:Y["NOT BORN" Y + ; + ;---> If over 60 months, return years. + Q:Y>60 $$AGE(DFN,1,$G(BMXDT))_" years" + ; + ;---> If under 1 month return days. + I Y<1 S Y=$$AGE(DFN,3,$G(BMXDT)) Q Y_$S(Y=1:" day",1:" days") + ; + ;---> Return months + Q Y_$S(Y=1:" month",1:" months") + ; + ; + ;---------- +DECEASED(DFN,BMXDT) ;EP + ;---> Return 1 if patient is deceased, 0 if not deceased. + ;---> Parameters: + ; 1 - DFN (req) Patient's IEN (DFN). + ; 2 - BMXDT (opt) If BMXDT=1 return Date of Death (Fileman format). + ; + Q:'$G(DFN) 0 + N X S X=+$G(^DPT(DFN,.35)) + Q:'X 0 + Q:'$G(BMXDT) 1 + Q X + ; + ; + ;---------- +SEX(DFN,PRON) ;EP + ;---> Return "F" is patient is female, "M" if male. + ;---> Parameters: + ; 1 - DFN (req) Patient's IEN (DFN). + ; 2 - PRON (opt) Pronoun: 1=he/she, 2=him/her,3=his,her + ; + Q:'$G(DFN) "" + Q:'$D(^DPT(DFN,0)) "" + N X S X=$P(^DPT(DFN,0),U,2) + Q:'$G(PRON) X + I PRON=1 Q $S(X="F":"she",1:"he") + I PRON=2 Q $S(X="F":"her",1:"him") + I PRON=3 Q $S(X="F":"her",1:"his") + Q X + ; + ; + ;---------- +SEXW(DFN) ;EP + ;---> Return Patient sex: "Female"/"Male". + ;---> Parameters: + ; 1 - DFN (req) Patient's IEN (DFN). + ; + Q:$$SEX(DFN)="M" "Male" + Q:$$SEX(DFN)="F" "Female" + Q "Unknown" + ; + ; + ;---------- +NAMAGE(DFN) ;EP + ;---> Return Patient Name concatenated with age. + ;---> Parameters: + ; 1 - DFN (req) Patient's IEN (DFN). + ; + Q:'$G(DFN) "NO PATIENT" + Q $$NAME(DFN)_" ("_$$AGE(DFN)_"y/o)" + ; + ; + ;---------- +SSN(DFN) ;EP + ;---> Return Social Security Number (SSN). + ;---> Parameters: + ; 1 - DFN (req) Patient's IEN (DFN). + N X + Q:'$G(DFN) "NO PATIENT" + Q:'$D(^DPT(DFN,0)) "Unknown" + S X=$P(^DPT(DFN,0),U,9) + Q:X']"" "Unknown" + Q X + ; + ; + ;---------- +HRCN(DFN,DUZ2,AGD) ;EP + ;---> Return IHS Health Record Number. + ;---> Parameters: + ; 1 - DFN (req) Patient's IEN (DFN). + ; 2 - DUZ2 (opt) User's Site/Location IEN. If no DUZ2 + ; provided, function will look for DUZ(2). + ; 3 - AGD (opt) If AGD=1 return HRCN with no dashes. + ; + ; + S:'$G(DUZ2) DUZ2=$G(DUZ(2)) + Q:'$G(DFN)!('$G(DUZ2)) "Unknown1" + Q:'$D(^AUPNPAT(DFN,41,DUZ2,0)) "Unknown2" + Q:'+$P(^AUPNPAT(DFN,41,DUZ2,0),"^",2) "Unknown3" + N Y S Y=$P(^AUPNPAT(DFN,41,DUZ2,0),"^",2) + Q:$G(AGD) Y + Q:'+Y Y + I $L(Y)=7 D Q Y + .S Y=$TR("123-45-67",1234567,Y) + S Y=$E("00000",0,6-$L(Y))_Y + S Y=$TR("12-34-56",123456,Y) + Q Y + ; + ; + ;---------- +PHONE(AGDFN,AGOFF) ;EP + ;---> Return patient's home phone number. + ;---> Parameters: + ; 1 - AGDFN (req) Patient's IEN (DFN). + ; 2 - AGOFF (opt) =1 will return Patient's Office Phone. + ; + Q:'$G(AGDFN) "Error: No DFN" + Q $P($G(^DPT(AGDFN,.13)),U,$S($G(AGOFF):2,1:1)) + ; + ; + ;---------- +STREET(DFN) ;EP + ;---> Return patient's street address. + ;---> Parameters: + ; 1 - DFN (req) Patient's IEN (DFN). + ; + Q:'$G(DFN) "No Patient" + Q:'$D(^DPT(DFN,.11)) "" + Q:$P(^DPT(DFN,.11),U)="" "" + Q $P(^DPT(DFN,.11),U) + ; + ; + ;---------- +CITY(DFN) ;EP + ;---> Return patient's city. + ;---> Parameters: + ; 1 - DFN (req) Patient's IEN (DFN). + ; + Q:'$G(DFN) "No Patient" + Q:'$D(^DPT(DFN,.11)) "" + Q:$P(^DPT(DFN,.11),U,4)="" "" + Q $P(^DPT(DFN,.11),U,4) + ; + ; + ;---------- +STATE(DFN,NOTEXT) ;EP + ;---> Return patient's state. + ;---> Parameters: + ; 1 - DFN (req) Patient's IEN (DFN). + ; 2 - NOTEXT (opt) If NOTEXT=1 return only the State IEN. + ; If NOTEXT=2 return IEN|Text. + ; + Q:'$G(DFN) "" + N Y S Y=$P($G(^DPT(DFN,.11)),U,5) + Q:$G(NOTEXT)=1 Y + Q:$G(NOTEXT)=2 Y_"|"_$$GET^BMXG(1,Y) + Q $$GET^BMXG(1,Y) + ; + ; + ;---------- +ZIP(DFN) ;EP + ;---> Return patient's zipcode. + ;---> Parameters: + ; 1 - DFN (req) Patient's IEN (DFN). + ; + Q:'$G(DFN) "No Patient" + Q:'$D(^DPT(DFN,.11)) "" + Q:$P(^DPT(DFN,.11),U,6)="" "" + Q $P(^DPT(DFN,.11),U,6) + ; + ; + ;---------- +CTYSTZ(DFN) ;EP + ;---> Return patient's city, state zip. + ;---> Parameters: + ; 1 - DFN (req) Patient's IEN (DFN). + ; + Q:'$G(DFN) "No Patient" + Q $$CITY(DFN)_", "_$$STATE(DFN)_" "_$$ZIP(DFN) + ; + ; +CURCOM(DFN,NOTEXT) ;EP + ;---> Return patient's Current Community IEN or Text. + ;---> (Item 6 on page 1 of Registration). + ;---> Parameters: + ; 1 - DFN (req) Patient's IEN (DFN). + ; 2 - NOTEXT (opt) If NOTEXT=1 return only the Current Comm IEN. + ; If NOTEXT=2 return IEN|Text. + ; + Q:'$G(DFN) "No Patient" + Q:'$D(^AUPNPAT(DFN,11)) "" ;"Unknown1" + ; + N X,Y,Z + S X=^AUPNPAT(DFN,11) + ;---> Set Y=Pointer (IEN in ^AUTTCOM, piece 17), Z=Text (piece 18). + S Y=$P(X,U,17),Z=$P(X,U,18) + ;---> If both Pointer and Text are null, return "Unknown2". + Q:('Y&(Z="")) "" ;"Unknown2" + ; + ;---> If Y is null or a bad pointer, set Y="". + I Y<1!('$D(^AUTTCOM(+Y,0))) S Y="" + ; + ;---> If no valid pointer and if Text (pc 18) exists in the + ;---> Community file, then set Y=IEN in ^AUTTCOM(. + I Y<1,$D(^AUTTCOM("B",Z)) S Y=$O(^AUTTCOM("B",Z,0)) + ; + Q:'$D(^AUTTCOM(+Y,0)) "" ;"Unknown3" + Q:$G(NOTEXT)=1 Y + Q:$G(NOTEXT)=2 Y_"|"_$$GET^BMXG(2,Y) + Q $$GET^BMXG(2,Y) + ; + ; + ;---------- +PERSON(X,ORDER) ;EP + ;---> Return person's name from File #200. + ;---> Parameters: + ; 1 - X (req) Person's IEN in New Person File #200. + ; 2 - ORDER (opt) ""/0=Last,First 1=First Last + ; + Q:'X "Unknown" + Q:'$D(^VA(200,X,0)) "Unknown" + N Y S Y=$P(^VA(200,X,0),U) + Q:'$G(ORDER) Y + Q $$FL(Y) Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXUTL2.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXUTL2.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXUTL2.m (revision 1147) @@ -0,0 +1,32 @@ +BMXUTL2 ; IHS/OIT/HMW - UTIL: PATIENT INFO ; + ;;4.1000;BMX;;Apr 17, 2011 + ;;Stolen from:* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER * + ;; UTILITY: PATIENT FUNCTIONS: CONTRAS, INPATIENT, HIDOSE. + ; +NEXTAPPT(BMXDFN) ;EP + ;---> Return patient's next appointment from Scheduling Package. + ;---> Parameters: + ; 1 - BMXDFN (req) Patient's IEN (BMXDFN). + ; + Q:'$G(BMXDFN) "" + Q:'$D(^DPT(BMXDFN)) "" + ; + N BMXAPPT,BMXDT,BMXYES + S BMXDT=DT+.2400,BMXYES=0 + F S BMXDT=$O(^DPT(BMXDFN,"S",BMXDT)) Q:'BMXDT!(BMXYES) D + .N BMXDATA,BMXOI,X + .S BMXDATA=$G(^DPT(BMXDFN,"S",BMXDT,0)) + .Q:BMXDATA="" + .; + .;---> Quit if appointment is cancelled. + .Q:$P(BMXDATA,U,2)["C" + .; + .S X=0 F S X=$O(^SC(+BMXDATA,"S",BMXDT,1,X)) Q:'X D + ..Q:+$G(^SC(+BMXDATA,"S",BMXDT,1,X,0))'=BMXDFN + ..S BMXYES=BMXDT_U_+BMXDATA + ; + Q:'BMXYES "" + ; + S BMXAPPT=$$FMTE^XLFDT(+BMXYES,"1P")_" with " + S BMXAPPT=BMXAPPT_$P($G(^SC($P(BMXYES,U,2),0)),U) + Q BMXAPPT Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXUTL5.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXUTL5.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXUTL5.m (revision 1147) @@ -0,0 +1,217 @@ +BMXUTL5 ; IHS/OIT/HMW - DATE FORMAT ; + ;;4.1000;BMX;;Apr 17, 2011 + ;;Stolen from:* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER * + ;; UTILITY: SETVARS, CENTERT, COPYLET, + ;; UPPERCASE XREFS, DATE FORMATS, PADS/SPACES. + ; + ; + ;---------- +SETVARS ;EP + ;---> Set standard variables. + D ^XBKVAR + S:'$D(IOF) IOF="#" + Q + ; + ; + ;---------- +PHONFIX(X) ;EP + ;---> Remove parentheses from Phone#. + ;---> Parameters: + ; 1 - X (req) Input Phone Number; returned without parentheses. + ; + Q:$G(X)="" + S X=$TR(X,"(","") + S X=$TR(X,")","-") + S X=$TR(X,"/","-") + S:X["- " X=$P(X,"- ")_"-"_$P(X,"- ",2) + S:$E(X,4)=" " $E(X,4)="-" + S:X["--" X=$P(X,"--")_"-"_$P(X,"--",2) + S:X?7N X=$E(X,1,3)_"-"_$E(X,4,7) + Q + ; + ; + ;---------- +CENTERT(TEXT,X) ;EP + ;---> Pad TEXT with leading spaces to center in 80 columns. + ;---> Parameters: + ; 1 - TEXT (req) Text to be centered. + ; 2 - X (opt) Columns to adjust to the right. + ; + S:$G(TEXT)="" TEXT="* NO TEXT SUPPLIED *" + S:'$G(X) X=39 + N I + F I=1:1:(X-($L(TEXT)/2)) S TEXT=" "_TEXT + Q + ; + ; + ;---------- +UPPER(X) ;EP + ;---> Translate X to all uppercase. + ;---> Parameters: + ; 1 - X (req) Value to be translated into all uppercase. + ; + S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + Q X + ; + ; + ;---------- +UPXREF(X,AGGBL) ;EP + ;---> Set uppercase xref for X. Called from M xrefs on mixed case + ;---> fields where an all uppercase lookup is needed. + ;---> Parameters: + ; 1 - X (req) The value that should be xrefed in uppercase. + ; 2 - AGGBL (req) The global root of the file. + ; + ;---> Variables: + ; 1 - DA (req) IEN of the entry being xrefed. + ; + Q:'$D(AGGBL) Q:$G(X)="" Q:'$G(DA) + S @(AGGBL_"""U"",$E($$UPPER(X),1,30),DA)")="" + Q + ; + ; + ;---------- +KUPXREF(X,AGGBL) ;EP + ;---> Kill uppercase xref for X. Called from M xrefs on mixed case + ;---> fields where an all uppercase lookup is needed. + ;---> Parameters: + ; 1 - X (req) The value that should be xrefed in uppercase. + ; 2 - AGGBL (req) The global root of the file. + ; + ;---> Variables: + ; 1 - DA (req) IEN of the entry being xrefed. + ; + Q:'$D(AGGBL) Q:$G(X)="" Q:'$G(DA) + K @(AGGBL_"""U"",$E($$UPPER(X),1,30),DA)") + Q + ; + ; + ;---------- +SLDT2(DATE) ;EP + ;---> CONVERT FILEMAN INTERNAL DATE TO "SLASH" FORMAT: MM/DD/YYYY. + ;---> DATE=DATE IN FILEMAN FORMAT. + Q:'$G(DATE) "NO DATE" + S DATE=$P(DATE,".") + Q:$L(DATE)'=7 DATE + Q:'$E(DATE,4,5) $E(DATE,1,3)+1700 + Q:'$E(DATE,6,7) $E(DATE,4,5)_"/"_$E(DATE,2,3) + Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_($E(DATE,1,3)+1700) + ; + ; + ;---------- +SLDT1(DATE) ;EP + ;---> CONVERT FILEMAN INTERNAL DATE TO "SLASH" FORMAT: + ;---> MM/DD/YYYY @TIME + N Y + Q:'$D(DATE) "NO DATE" + S Y=DATE,DATE=$P(DATE,".") + Q:'DATE "NO DATE" + Q:$L(DATE)'=7 DATE + Q:'$E(DATE,4,5) $E(DATE,1,3)+1700 + Q:'$E(DATE,6,7) $E(DATE,4,5)_"/"_$E(DATE,2,3) + D DD^%DT S:Y["@" Y=" @ "_$P($P(Y,"@",2),":",1,2) + Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_($E(DATE,1,3)+1700)_Y + ; + ; + ;---------- +NOSLDT(DATE) ;EP + ;---> CONVERT FILEMAN INTERNAL DATE TO "NO SLASH" FORMAT: MMDDYYYY. + ;---> DATE=DATE IN FILEMAN FORMAT. + Q:'$G(DATE) "NO DATE" + S DATE=$P(DATE,".") + Q:$L(DATE)'=7 DATE + Q $E(DATE,4,5)_$E(DATE,6,7)_($E(DATE,1,3)+1700) + ; + ; + ;---------- +IMMSDT(DATE) ;EP + ;---> Convert Immserve Date (format MMDDYYYY) TO FILEMAN + ;---> Internal format. + ;---> NOTE: This code is copied into routine ^AGPATUP1 for speed. + ;---> Any changes here should also be made to the call in ^AGPATUP1. + Q:'$G(DATE) "NO DATE" + Q ($E(DATE,5,9)-1700)_$E(DATE,1,2)_$E(DATE,3,4) + ; + ; + ;---------- +TXDT1(DATE,TIME) ;EP + ;---> Return external date in format: DD-Mmm-YYYY@HH:MM, from Fileman + ;---> internal YYYMMDD.HHMM + ;---> Parameters: + ; 1 - DATE (req) Internal Fileman date. + ; 2 - TIME (opt) + ; + Q:'$G(DATE) "NO DATE" + N X,Y,Z + S X="Jan^Feb^Mar^Apr^May^Jun^Jul^Aug^Sep^Oct^Nov^Dec" + S Y=$E(DATE,6,7)_"-"_$P(X,U,$E(DATE,4,5))_"-"_($E(DATE,1,3)+1700) + S:'$E(DATE,6,7) Y=$E(Y,4,99) + S:'$E(DATE,4,5) Y=$E(DATE,1,3)+1700 + Q:'$G(TIME) Y + S Z=$P(DATE,".",2) + Q:'Z Y + Q Y_" @"_$E(Z,1,2)_":"_$$PAD($E(Z,3,4),2,"0") + ; + ; + ;---------- +TXDT(DATE) ;EP + ;---> CONVERT FILEMAN INTERNAL DATE TO "TEXT" FORMAT: MMM DD,YYYY. + N Y + Q:'$D(DATE) "NO DATE" + S Y=DATE D DD^%DT + I Y[", " S Y=$P(Y,", ")_","_$P(Y,", ",2) + I Y["@" S Y=$P(Y,"@")_" "_$P($P(Y,"@",2),":",1,2) + Q Y + ; + ; + ;---------- +NOW() ;EP + ;---> Return Current Date and Time in external format. + N %H,X,Y,Z + S %H=$H + D YX^%DTC + I Y["@" S Y=$P($P(Y,"@",2),":",1,2) + S Z=$$TXDT1(X) + S:Y]"" Z=Z_" @"_Y + Q Z + ; + ; + ;---------- +PAD(D,L,C) ;EP + ;---> Pad the length of data to a total of L characters + ;---> by adding spaces to the end of the data. + ; Example: S X=$$PAD("MIKE",7) X="MIKE " (Added 3 spaces.) + ;---> Parameters: + ; 1 - D (req) Data to be padded. + ; 2 - L (req) Total length of resulting data. + ; 3 - C (opt) Character to pad with (default=space). + ; + Q:'$D(D) "" + S:'$G(L) L=$L(D) + S:$G(C)="" C=" " + Q $E(D_$$REPEAT^XLFSTR(C,L),1,L) + ; + ; + ;---------- +SP(N,C) ;EP + ;---> Return N spaces or other character. + ; Example: S X=$$SP(5)_X Pads the front of X with 5 spaces. + ;---> Parameters: + ; 1 - N (req) Number of spaces to be returned as extrinsic var. + ; 2 - C (opt) Character to pad with (default=space). + ; + Q:$G(N)<1 "" + S:$G(C)="" C=" " + Q $$PAD(C,N,C) + ; + ; + ;---------- +STRIP(X) ;EP + ;---> Strip any punctuation characters from the beginning of X, + ;---> including spaces. + ;---> Parameters: + ; 1 - X (req) String of characters. + ; + Q:$G(X)="" "" + F Q:$E(X)'?1P S X=$E(X,2,99) + Q X Index: /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXUTL6.m =================================================================== --- /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXUTL6.m (revision 1147) +++ /BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXUTL6.m (revision 1147) @@ -0,0 +1,41 @@ +BMXUTL6 ; IHS/OIT/HMW - BMXNET INSTALLATION CALLS ; + ;;4.1000;BMX;;Apr 17, 2011 + ; + ; +POST ;EP - Called from BMX Installation postinit + ; + ;Add BMX AV CODE and BMX CONNECT STATUS to XUS SIGNON broker option + N BMXFDA,BMXIEN,BMXMSG,BMXIENS,BMXMENN,BMXAVI,BMXCS,BMXOPT,BMXCVC + S BMXAVI=$O(^XWB(8994,"B","BMX AV CODE",0)) + Q:'+BMXAVI + S BMXCS=$O(^XWB(8994,"B","BMX CONNECT STATUS",0)) + Q:'+BMXCS + S BMXCVC=$O(^XWB(8994,"B","BMX CVC",0)) + Q:'+BMXCVC + S BMXIENS=$O(^DIC(19,"B","XUS SIGNON",0)) + Q:'+BMXIENS + ; +UPDATE S BMXIENS="?+2,"_BMXIENS_",",DIC(0)="" + F BMXOPT=BMXAVI,BMXCS,BMXCVC D + . S BMXFDA(19.05,BMXIENS,.01)=BMXOPT + . K BMXIEN,BMXMSG + . D UPDATE^DIE("","BMXFDA","BMXIEN","BMXMSG") + . Q + Q + ; + ; + ; + ;Create BMXNET,APPLICATION user and set attributes + ; + ;N BMXFDA,BMXIEN,BMXMSG,BMXIENS,BMXMENN + ;S BMXIENS = "?+1," + ;S BMXFDA(200,BMXIENS,.01)="BMXNET,APPLICATION" + ;S BMXFDA(200,BMXIENS,2)="1_(a>yr}:3x3ja9\8vbH" + ;S BMXFDA(200,BMXIENS,11)="$;HOSs|:3w25lLD}Be=" + ;S BMXFDA(200,BMXIENS,11.2)="88888,88888" + ;S BMXMENN=$O(^DIC(19,"B","BMXRPC",0)) + ;I +BMXMENN S BMXFDA(200.03,"?+2,?+1,",.01)=BMXMENN + ;K BMXIEN,BMXMSG + ;S DIC(0)="" + ;D UPDATE^DIE("","BMXFDA","BMXIEN","BMXMSG") + Q